From fd8ea1e1b9cae781abe42aeadda2e0ef149994d6 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 5 Nov 2022 21:23:20 -0400 Subject: Property-based testing can now log/print successful seeds from run. --- stdlib/source/library/lux/control/exception.lux | 22 +-- .../source/library/lux/control/function/named.lux | 8 +- .../lux/control/function/polymorphism/context.lux | 4 +- .../control/function/polymorphism/predicate.lux | 16 +- .../lux/control/function/polymorphism/type.lux | 12 +- .../library/lux/control/function/variadic.lux | 8 +- .../library/lux/control/security/capability.lux | 10 +- stdlib/source/library/lux/meta/macro/context.lux | 6 +- .../library/lux/meta/macro/syntax/export.lux | 4 +- .../source/library/lux/meta/macro/vocabulary.lux | 2 +- stdlib/source/library/lux/meta/type/primitive.lux | 14 +- stdlib/source/library/lux/meta/type/row.lux | 2 +- stdlib/source/library/lux/test/property.lux | 31 +++- stdlib/source/library/lux/world/net.lux | 8 +- stdlib/source/library/lux/world/net/uri/port.lux | 103 ++++++++++++ stdlib/source/library/lux/world/net/uri/scheme.lux | 14 +- stdlib/source/specification/lux/abstract/apply.lux | 101 ++++++------ .../source/specification/lux/abstract/comonad.lux | 77 ++++----- stdlib/source/test/lux.lux | 2 +- stdlib/source/test/lux/test/property.lux | 7 +- stdlib/source/test/lux/world/net.lux | 4 +- stdlib/source/test/lux/world/net/uri/port.lux | 177 +++++++++++++++++++++ stdlib/source/test/lux/world/net/uri/scheme.lux | 14 +- 23 files changed, 462 insertions(+), 184 deletions(-) create mode 100644 stdlib/source/library/lux/world/net/uri/port.lux create mode 100644 stdlib/source/test/lux/world/net/uri/port.lux (limited to 'stdlib') diff --git a/stdlib/source/library/lux/control/exception.lux b/stdlib/source/library/lux/control/exception.lux index fabba5ad5..55ac0667d 100644 --- a/stdlib/source/library/lux/control/exception.lux +++ b/stdlib/source/library/lux/control/exception.lux @@ -75,17 +75,17 @@ (.def exceptionP (Parser [export.Policy [[Text Code] Code Code]]) - (export.parser - (all <>.either - (all <>.and - (.form (<>.and .local .any)) - .any - .any) - (do <>.monad - [name .local] - (in [[name (code.local name)] - (` (Exception Any)) - (` "")]))))) + (export.with + (all <>.either + (all <>.and + (.form (<>.and .local .any)) + .any + .any) + (do <>.monad + [name .local] + (in [[name (code.local name)] + (` (Exception Any)) + (` "")]))))) (.def .public def (syntax (_ [[export_policy [[name input] type body]] ..exceptionP]) diff --git a/stdlib/source/library/lux/control/function/named.lux b/stdlib/source/library/lux/control/function/named.lux index eeade0ed5..39e0fba22 100644 --- a/stdlib/source/library/lux/control/function/named.lux +++ b/stdlib/source/library/lux/control/function/named.lux @@ -40,10 +40,10 @@ (.def .public def (syntax (_ [[exported? [name parameters] type body] - (export.parser (all ?.and - (?code.form (?.and ?code.local (?.some ?code.local))) - ?code.any - ?code.any))]) + (export.with (all ?.and + (?code.form (?.and ?code.local (?.some ?code.local))) + ?code.any + ?code.any))]) (do meta.monad [here meta.current_module_name] (if (n.= (list.size parameters) diff --git a/stdlib/source/library/lux/control/function/polymorphism/context.lux b/stdlib/source/library/lux/control/function/polymorphism/context.lux index 904cc100c..be28c494e 100644 --- a/stdlib/source/library/lux/control/function/polymorphism/context.lux +++ b/stdlib/source/library/lux/control/function/polymorphism/context.lux @@ -41,7 +41,7 @@ (.def .public layer - (syntax (_ [[export_policy name] (export.parser ?code.local)]) + (syntax (_ [[export_policy name] (export.with ?code.local)]) (do meta.monad [@ meta.current_module_name] (in (list (` (.def (, export_policy) (, (code.local name)) @@ -118,7 +118,7 @@ (` ((,' .,') (, it)))) (.def .public def - (syntax (_ [[export_policy signature] (export.parser ..signature) + (syntax (_ [[export_policy signature] (export.with ..signature) quantifications (?code.tuple (?.some ?code.any)) context ?code.any inputs (?code.tuple (?.many ?code.any)) diff --git a/stdlib/source/library/lux/control/function/polymorphism/predicate.lux b/stdlib/source/library/lux/control/function/polymorphism/predicate.lux index 78a238fa4..3a145e7eb 100644 --- a/stdlib/source/library/lux/control/function/polymorphism/predicate.lux +++ b/stdlib/source/library/lux/control/function/polymorphism/predicate.lux @@ -58,14 +58,14 @@ (.def .public def (syntax (_ [[export_policy signature quantifications inputs output default methods] - (export.parser - (all ?.and - ..signature - (?code.tuple (?.some ?code.any)) - (?code.tuple (?.many ?code.any)) - ?code.any - ?code.any - (?.some ?code.any)))]) + (export.with + (all ?.and + ..signature + (?code.tuple (?.some ?code.any)) + (?code.tuple (?.many ?code.any)) + ?code.any + ?code.any + (?.some ?code.any)))]) (<| (with_symbols [g!self g!_ g!scenarios g!scenario g!mixin]) (..declaration [#function (the #name signature) #quantifications quantifications diff --git a/stdlib/source/library/lux/control/function/polymorphism/type.lux b/stdlib/source/library/lux/control/function/polymorphism/type.lux index 6dbd0ef42..5aec52b70 100644 --- a/stdlib/source/library/lux/control/function/polymorphism/type.lux +++ b/stdlib/source/library/lux/control/function/polymorphism/type.lux @@ -34,12 +34,12 @@ (.def .public def (syntax (_ [[export_policy name parameters type methods] - (export.parser - (all ?.and - ?code.local - (?code.tuple (?.many ?code.local)) - ?code.any - (?.many ?code.any)))]) + (export.with + (all ?.and + ?code.local + (?code.tuple (?.many ?code.local)) + ?code.any + (?.many ?code.any)))]) (<| (do meta.monad [@ meta.current_module_name g!interface (macro.symbol name) diff --git a/stdlib/source/library/lux/control/function/variadic.lux b/stdlib/source/library/lux/control/function/variadic.lux index 5b53bbe83..e914dde9e 100644 --- a/stdlib/source/library/lux/control/function/variadic.lux +++ b/stdlib/source/library/lux/control/function/variadic.lux @@ -36,10 +36,10 @@ (.def .public def (syntax (_ [[exported? [name parameters] type body] - (export.parser (all ?.and - (?code.form (?.and ?code.local (?.some ?code.local))) - ?code.any - ?code.any))]) + (export.with (all ?.and + (?code.form (?.and ?code.local (?.some ?code.local))) + ?code.any + ?code.any))]) (do meta.monad [here meta.current_module_name] (if (n.= (list.size parameters) diff --git a/stdlib/source/library/lux/control/security/capability.lux b/stdlib/source/library/lux/control/security/capability.lux index e422ba4ed..bdcc86586 100644 --- a/stdlib/source/library/lux/control/security/capability.lux +++ b/stdlib/source/library/lux/control/security/capability.lux @@ -18,7 +18,7 @@ ["<[1]>" \\parser]] ["[0]" macro (.only) [syntax (.only syntax) - ["|[0]|" export] + ["[0]" export] ["|[0]|" declaration]]] [type ["[0]" primitive (.except def)]]]]]) @@ -35,10 +35,10 @@ (def .public capability (syntax (_ [[export_policy declaration [forger input output]] - (|export|.parser - (all <>.and - |declaration|.parser - (.form (all <>.and .local .any .any))))]) + (export.with + (all <>.and + |declaration|.parser + (.form (all <>.and .local .any .any))))]) (macro.with_symbols [g!_] (do [! meta.monad] [this_module meta.current_module_name diff --git a/stdlib/source/library/lux/meta/macro/context.lux b/stdlib/source/library/lux/meta/macro/context.lux index c39bbd539..4ec34b5df 100644 --- a/stdlib/source/library/lux/meta/macro/context.lux +++ b/stdlib/source/library/lux/meta/macro/context.lux @@ -230,9 +230,9 @@ (syntax (_ [.let [! ?.monad ?local (at ! each code.local ?code.local)] - [export_$? $] (?code.tuple (export.parser ?code.local)) - [export_expression? g!expression] (?code.tuple (export.parser ?local)) - [export_declaration? g!declaration] (?code.tuple (export.parser ?local)) + [export_$? $] (?code.tuple (export.with ?code.local)) + [export_expression? g!expression] (?code.tuple (export.with ?local)) + [export_declaration? g!declaration] (?code.tuple (export.with ?local)) context_type ?code.any]) (do [! meta.monad] diff --git a/stdlib/source/library/lux/meta/macro/syntax/export.lux b/stdlib/source/library/lux/meta/macro/syntax/export.lux index 98db6124e..522fefb6b 100644 --- a/stdlib/source/library/lux/meta/macro/syntax/export.lux +++ b/stdlib/source/library/lux/meta/macro/syntax/export.lux @@ -1,6 +1,6 @@ (.require [library - [lux (.except) + [lux (.except with) [abstract [monad (.only do)]] [control @@ -37,6 +37,6 @@ _ (in default))))) -(def .public parser +(def .public with (All (_ a) (-> (Parser a) (Parser [Policy a]))) (<>.and ..policy)) diff --git a/stdlib/source/library/lux/meta/macro/vocabulary.lux b/stdlib/source/library/lux/meta/macro/vocabulary.lux index 31e0dc1d9..71327712d 100644 --- a/stdlib/source/library/lux/meta/macro/vocabulary.lux +++ b/stdlib/source/library/lux/meta/macro/vocabulary.lux @@ -25,7 +25,7 @@ (.def local (Parser [Code Code]) - (?code.tuple (export.parser (?#each code.local ?code.local)))) + (?code.tuple (export.with (?#each code.local ?code.local)))) (.def .public def (syntax (_ [[public|private@type type] ..local diff --git a/stdlib/source/library/lux/meta/type/primitive.lux b/stdlib/source/library/lux/meta/type/primitive.lux index db066d253..033be6d6e 100644 --- a/stdlib/source/library/lux/meta/type/primitive.lux +++ b/stdlib/source/library/lux/meta/type/primitive.lux @@ -17,7 +17,7 @@ ["[0]" macro (.only) ["[0]" context] [syntax (.only syntax) - ["|[0]|" export]]]]]] + ["[0]" export]]]]]] ["[0]" //]) (type .public Frame @@ -70,12 +70,12 @@ (.def abstract (Parser [Code [Text (List Text)] Code (List Code)]) - (|export|.parser - (all <>.and - ..declarationP - .any - (<>.some .any) - ))) + (export.with + (all <>.and + ..declarationP + .any + (<>.some .any) + ))) ... TODO: Make sure the generated code always gets optimized away. ... (This applies to uses of "abstraction" and "representation") diff --git a/stdlib/source/library/lux/meta/type/row.lux b/stdlib/source/library/lux/meta/type/row.lux index c4c8b9b1f..3d3ac324d 100644 --- a/stdlib/source/library/lux/meta/type/row.lux +++ b/stdlib/source/library/lux/meta/type/row.lux @@ -103,7 +103,7 @@ (n.= (list.size it)))) (def .public type - (syntax (_ [[export_policy [name parameters]] (export.parser ..declaration) + (syntax (_ [[export_policy [name parameters]] (export.with ..declaration) [super slots] ..definition]) (let [slot_names (list#each product.left slots)] (if (unique_slots? slot_names) diff --git a/stdlib/source/library/lux/test/property.lux b/stdlib/source/library/lux/test/property.lux index 732be561f..db3adfb11 100644 --- a/stdlib/source/library/lux/test/property.lux +++ b/stdlib/source/library/lux/test/property.lux @@ -108,8 +108,19 @@ (exception.def .public must_try_test_at_least_once) -(def .public (times amount test) - (-> Nat Test Test) +(type .public Success_Policy + Bit) + +(def .public ignore_success + Success_Policy + #0) + +(def .public announce_success + Success_Policy + #1) + +(def .public (times amount announce_success? test) + (-> Nat Success_Policy Test Test) (when amount 0 (..failure (exception.error ..must_try_test_at_least_once [])) _ (do random.monad @@ -120,12 +131,16 @@ [[tally documentation] instance] (if (..failed? tally) (in [tally (times_failure seed documentation)]) - (when amount - 1 instance - _ (|> test - (times (-- amount)) - (random.result prng') - product.right))))]))))) + (exec + (if announce_success? + (debug.log! (format "Succeeded with this seed: " (%.nat seed))) + []) + (when amount + 1 instance + _ (|> test + (times (-- amount) announce_success?) + (random.result prng') + product.right)))))]))))) (def (description duration tally) (-> Duration Tally Text) diff --git a/stdlib/source/library/lux/world/net.lux b/stdlib/source/library/lux/world/net.lux index fccb47177..4bbf75cd3 100644 --- a/stdlib/source/library/lux/world/net.lux +++ b/stdlib/source/library/lux/world/net.lux @@ -1,13 +1,13 @@ (.require [library - [lux (.except #host)]]) + [lux (.except #host)]] + [/ + [uri + [port (.only Port)]]]) (type .public Host Text) -(type .public Port - Nat) - (type .public URL Text) diff --git a/stdlib/source/library/lux/world/net/uri/port.lux b/stdlib/source/library/lux/world/net/uri/port.lux new file mode 100644 index 000000000..3b6d8a8e5 --- /dev/null +++ b/stdlib/source/library/lux/world/net/uri/port.lux @@ -0,0 +1,103 @@ +... https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers +(.require + [library + [lux (.except) + [meta + [macro + ["[0]" template]]]]]) + +(type .public Port + Nat) + +(with_template [ '] + [(def .public + Port + ) + + (with_expansions [ (template.spliced ')] + (with_template [] + [(def .public )] + + + ))] + + [007 echo_protocol []] ... https://en.wikipedia.org/wiki/Echo_Protocol + [009 discard_protocol []] ... https://en.wikipedia.org/wiki/Discard_Protocol + [013 daytime_protocol []] ... https://en.wikipedia.org/wiki/Daytime_Protocol + [017 quote_of_the_day []] ... https://en.wikipedia.org/wiki/QOTD + [018 message_send_protocol []] ... https://en.wikipedia.org/wiki/Message_Send_Protocol + [019 character_generator_protocol []] ... https://en.wikipedia.org/wiki/Character_Generator_Protocol + [020 file_transfer_protocol_data_transfer [[ftp_data_transfer]]] + [021 file_transfer_protocol_control [[ftp_control]]] + [023 telnet []] ... https://en.wikipedia.org/wiki/Telnet + [025 simple_mail_transfer_protocol [[smtp]]] ... https://en.wikipedia.org/wiki/Simple_Mail_Transfer_Protocol + [037 time_protocol []] ... https://en.wikipedia.org/wiki/Time_Protocol + [042 host_name_server_protocol []] ... https://en.wikipedia.org/wiki/ARPA_Host_Name_Server_Protocol + [043 whois []] ... https://en.wikipedia.org/wiki/WHOIS + [053 domain_name_system [[dns]]] ... https://en.wikipedia.org/wiki/Domain_Name_System + [070 gopher []] ... https://en.wikipedia.org/wiki/Gopher_(protocol) + [079 finger []] ... https://en.wikipedia.org/wiki/Finger_(protocol) + [080 hypertext_transfer_protocol [[http]]] ... https://en.wikipedia.org/wiki/Hypertext_Transfer_Protocol + [088 kerberos []] ... https://en.wikipedia.org/wiki/Kerberos_(protocol) + + [104 digital_imaging_and_communications_in_medicine [[dicom]]] ... https://en.wikipedia.org/wiki/DICOM + [107 remote_user_telnet_service [[rtelnet]]] ... https://en.wikipedia.org/wiki/Rtelnet + [109 post_office_protocol_2 [[pop2]]] ... https://en.wikipedia.org/wiki/Post_Office_Protocol + [110 post_office_protocol_3 [[pop3]]] ... https://en.wikipedia.org/wiki/Post_Office_Protocol + [111 open_network_computing_remote_procedure_call [[onc_rpc]]] ... https://en.wikipedia.org/wiki/Sun_RPC + [115 simple_file_transfer_protocol [[simple_ftp]]] ... https://en.wikipedia.org/wiki/File_Transfer_Protocol#Simple_File_Transfer_Protocol + [119 network_news_transfer_protocol [[nntp]]] ... https://en.wikipedia.org/wiki/Network_News_Transfer_Protocol + [123 network_time_protocol [[ntp]]] ... https://en.wikipedia.org/wiki/Network_Time_Protocol + [143 internet_message_access_protocol [[imap]]] ... https://en.wikipedia.org/wiki/Internet_Message_Access_Protocol + [153 simple_gateway_monitoring_protocol [[sgmp]]] ... https://en.wikipedia.org/wiki/Simple_Gateway_Monitoring_Protocol + [156 structured_query_language [[sql]]] ... https://en.wikipedia.org/wiki/SQL + [161 simple_network_management_protocol [[snmp]]] ... https://en.wikipedia.org/wiki/Simple_Network_Management_Protocol + [162 simple_network_management_protocol_trap [[snmp_trap]]] ... https://en.wikipedia.org/wiki/Simple_Network_Management_Protocol + [169 secure_neighbor_discovery [[send]]] ... https://en.wikipedia.org/wiki/Secure_Neighbor_Discovery + [177 x_display_manager_control_protocol [[xdmcp]]] ... https://en.wikipedia.org/wiki/X_display_manager#XDMCP + [179 border_gateway_protocol [[bgp]]] ... https://en.wikipedia.org/wiki/Border_Gateway_Protocol + [194 internet_relay_chat [[irc]]] ... https://en.wikipedia.org/wiki/Internet_Relay_Chat + [199 snmp_unix_multiplexer [[smux]]] ... https://datatracker.ietf.org/doc/html/rfc1227#page-8 + + [264 border_gateway_multicast_protocol [[bgmp]]] ... https://en.wikipedia.org/wiki/Border_Gateway_Multicast_Protocol + + [319 precision_time_protocol_event_messages [[ptp_event_messages]]] ... https://en.wikipedia.org/wiki/Precision_Time_Protocol + [320 precision_time_protocol_general_messages [[ptp_general_messages]]] ... https://en.wikipedia.org/wiki/Precision_Time_Protocol + [389 lightweight_directory_access_protocol [[ldap]]] ... https://en.wikipedia.org/wiki/Lightweight_Directory_Access_Protocol + + [401 uninterruptible_power_supply [[ups]]] ... https://en.wikipedia.org/wiki/Uninterruptible_power_supply + [427 service_location_protocol [[slp]]] ... https://en.wikipedia.org/wiki/Service_Location_Protocol + [443 hypertext_transfer_protocol_secure [[https]]] ... https://en.wikipedia.org/wiki/HTTPS + [444 simple_network_paging_protocol [[snpp]]] ... https://en.wikipedia.org/wiki/Simple_Network_Paging_Protocol + [464 kerberos_change/set_password []] ... https://en.wikipedia.org/wiki/Kerberos_(protocol) + + [530 remote_procedure_call [[rpc]]] ... https://en.wikipedia.org/wiki/Remote_procedure_call + [554 real_time_streaming_protocol [[rtsp]]] ... https://en.wikipedia.org/wiki/Real_Time_Streaming_Protocol + [546 dynamic_host_configuration_protocol/6_client [[dhcp/6_client]]] ... https://en.wikipedia.org/wiki/Dynamic_Host_Configuration_Protocol + [547 dynamic_host_configuration_protocol/6_server [[dhcp/6_server]]] ... https://en.wikipedia.org/wiki/Dynamic_Host_Configuration_Protocol + [563 network_news_transfer_protocol_secure [[nntps]]] ... https://en.wikipedia.org/wiki/Network_News_Transfer_Protocol + + [631 internet_printing_protocol [[ipp]]] ... https://en.wikipedia.org/wiki/Internet_Printing_Protocol + [636 lightweight_directory_access_protocol_secure [[ldaps]]] ... https://en.wikipedia.org/wiki/Lightweight_Directory_Access_Protocol + [639 multicast_source_discovery_protocol [[msdp]]] ... https://en.wikipedia.org/wiki/Multicast_Source_Discovery_Protocol + [646 label_distribution_protocol [[ldp]]] ... https://en.wikipedia.org/wiki/Label_Distribution_Protocol + [674 application_configuration_access_protocol [[acap]]] ... https://en.wikipedia.org/wiki/Application_Configuration_Access_Protocol + [698 optimized_link_state_routing_protocol [[olsr]]] ... https://en.wikipedia.org/wiki/Optimized_Link_State_Routing_Protocol + + [700 extensible_provisioning_protocol [[epp]]] ... https://en.wikipedia.org/wiki/Extensible_Provisioning_Protocol + [701 link_management_protocol [[lmp]]] ... https://www.ietf.org/rfc/rfc4204.txt + [706 secure_internet_live_conferencing_protocol [[silc]]] ... https://en.wikipedia.org/wiki/SILC_(protocol) + [749 kerberos_administration []] ... https://en.wikipedia.org/wiki/Kerberos_(protocol) + + [829 certificate_management_protocol [[cmp]]] ... https://en.wikipedia.org/wiki/Certificate_Management_Protocol + [830 network_configuration_protocol/ssh [[netconf/ssh]]] ... https://en.wikipedia.org/wiki/NETCONF + [831 network_configuration_protocol/beep [[netconf/beep]]] ... https://en.wikipedia.org/wiki/NETCONF + [832 network_configuration_protocol/soap/https [[netconf/soap/https]]] ... https://en.wikipedia.org/wiki/NETCONF + [833 network_configuration_protocol/soap/beep [[netconf/soap/beep]]] ... https://en.wikipedia.org/wiki/NETCONF + + [989 file_transfer_protocol_secure_data_transfer [[ftps_data_transfer]]] ... https://en.wikipedia.org/wiki/FTPS + [990 file_transfer_protocol_secure_control [[ftps_control]]] ... https://en.wikipedia.org/wiki/FTPS + [992 telnet/tls []] ... https://en.wikipedia.org/wiki/Telnet + [993 internet_message_access_protocol_secure [[imaps]]] ... https://en.wikipedia.org/wiki/Internet_Message_Access_Protocol + [995 post_office_protocol_3_secure [[pop3s]]] ... https://en.wikipedia.org/wiki/Post_Office_Protocol + ) diff --git a/stdlib/source/library/lux/world/net/uri/scheme.lux b/stdlib/source/library/lux/world/net/uri/scheme.lux index 2c5d7b36f..aabe810b1 100644 --- a/stdlib/source/library/lux/world/net/uri/scheme.lux +++ b/stdlib/source/library/lux/world/net/uri/scheme.lux @@ -95,30 +95,30 @@ [ftp file_transfer_protocol] [http hypertext_transfer_protocol] - [https secure_hypertext_transfer_protocol] + [https hypertext_transfer_protocol_secure] [imap internet_message_access_protocol] [ipp internet_printing_protocol] - [ipps secure_internet_printing_protocol] + [ipps internet_printing_protocol_secure] [irc internet_relay_chat] - [ircs secure_internet_relay_chat] + [ircs internet_relay_chat_secure] [ldap lightweight_directory_access_protocol] - [ldaps secure_lightweight_directory_access_protocol] + [ldaps lightweight_directory_access_protocol_secure] [pop post_office_protocol] [sip session_initiation_protocol] - [sips secure_session_initiation_protocol] + [sips session_initiation_protocol_secure] [sms short_message_service] [snmp simple_network_management_protocol] [ssh secure_shell_protocol] [stun session_traversal_utilities_for_nat] - [stuns secure_session_traversal_utilities_for_nat] + [stuns session_traversal_utilities_for_nat_secure] [turn traversal_using_relays_around_nat] - [turns secure_traversal_using_relays_around_nat] + [turns traversal_using_relays_around_nat_secure] [xmpp extensible_messaging_and_presence_protocol] ) diff --git a/stdlib/source/specification/lux/abstract/apply.lux b/stdlib/source/specification/lux/abstract/apply.lux index 607024f11..eaf4d741c 100644 --- a/stdlib/source/specification/lux/abstract/apply.lux +++ b/stdlib/source/specification/lux/abstract/apply.lux @@ -16,64 +16,53 @@ [\\library ["[0]" / (.only Apply)]] [// - [functor (.only Injection Comparison)]]) + ["[0]S" functor (.only Injection Comparison)]]) -(def (identity injection comparison (open "/#[0]")) +(def .public (spec injection comparison it) (All (_ f) (-> (Injection f) (Comparison f) (Apply f) Test)) - (do [! random.monad] - [sample (at ! each injection random.nat)] - (_.test "Identity." - ((comparison n.=) - (/#on sample (injection function.identity)) - sample)))) + (<| (_.for [/.Apply]) + (type.let [:$/1: (-> Nat Nat)]) + (do [! random.monad] + [sample random.nat + increase (is (Random :$/1:) + (at ! each n.+ random.nat)) + decrease (is (Random :$/1:) + (at ! each n.- random.nat))]) + (all _.and + (_.for [/.functor] + (functorS.spec injection comparison (the /.functor it))) -(def (homomorphism injection comparison (open "/#[0]")) - (All (_ f) (-> (Injection f) (Comparison f) (Apply f) Test)) - (do [! random.monad] - [sample random.nat - increase (at ! each n.+ random.nat)] - (_.test "Homomorphism." - ((comparison n.=) - (/#on (injection sample) (injection increase)) - (injection (increase sample)))))) + (_.coverage [/.on] + (let [(open "/#[0]") it -(def (interchange injection comparison (open "/#[0]")) - (All (_ f) (-> (Injection f) (Comparison f) (Apply f) Test)) - (do [! random.monad] - [sample random.nat - increase (at ! each n.+ random.nat)] - (_.test "Interchange." - ((comparison n.=) - (/#on (injection sample) (injection increase)) - (/#on (injection increase) (injection (is (-> (-> Nat Nat) Nat) - (function (_ f) (f sample))))))))) + identity! + ((comparison n.=) + (/#on (injection sample) + (injection function.identity)) + (injection sample)) -(def (composition injection comparison (open "/#[0]")) - (All (_ f) (-> (Injection f) (Comparison f) (Apply f) Test)) - (type.let [:$/1: (-> Nat Nat)] - (do [! random.monad] - [sample random.nat - increase (is (Random :$/1:) - (at ! each n.+ random.nat)) - decrease (is (Random :$/1:) - (at ! each n.- random.nat))] - (_.test "Composition." - ((comparison n.=) - (|> (injection (is (-> :$/1: :$/1: :$/1:) - function.composite)) - (/#on (injection increase)) - (/#on (injection decrease)) - (/#on (injection sample))) - (/#on (/#on (injection sample) - (injection increase)) - (injection decrease))))))) - -(def .public (spec injection comparison apply) - (All (_ f) (-> (Injection f) (Comparison f) (Apply f) Test)) - (_.for [/.Apply] - (all _.and - (..identity injection comparison apply) - (..homomorphism injection comparison apply) - (..interchange injection comparison apply) - (..composition injection comparison apply) - ))) + homomorphism! + ((comparison n.=) + (/#on (injection sample) (injection increase)) + (injection (increase sample))) + + interchange! + ((comparison n.=) (/#on (injection sample) (injection increase)) + (/#on (injection increase) (injection (is (-> (-> Nat Nat) Nat) + (function (_ f) (f sample)))))) + + composition! + ((comparison n.=) + (|> (injection (is (-> :$/1: :$/1: :$/1:) + function.composite)) + (/#on (injection increase)) + (/#on (injection decrease)) + (/#on (injection sample))) + (/#on (/#on (injection sample) + (injection increase)) + (injection decrease)))] + (and identity! + homomorphism! + interchange! + composition!))) + ))) diff --git a/stdlib/source/specification/lux/abstract/comonad.lux b/stdlib/source/specification/lux/abstract/comonad.lux index 2583715f2..9763f136b 100644 --- a/stdlib/source/specification/lux/abstract/comonad.lux +++ b/stdlib/source/specification/lux/abstract/comonad.lux @@ -12,51 +12,42 @@ [\\library ["[0]" / (.only CoMonad)]] [// - [functor (.only Injection Comparison)]]) + ["[0]S" functor (.only Injection Comparison)]]) -(def (left_identity injection (open "_//[0]")) - (All (_ f) (-> (Injection f) (CoMonad f) Test)) - (do [! random.monad] - [sample random.nat - morphism (at ! each (function (_ diff) - (|>> _//out (n.+ diff))) - random.nat) - .let [start (injection sample)]] - (_.test "Left identity." - (n.= (morphism start) - (|> start _//disjoint (_//each morphism) _//out))))) - -(def (right_identity injection comparison (open "_//[0]")) - (All (_ f) (-> (Injection f) (Comparison f) (CoMonad f) Test)) - (do random.monad - [sample random.nat - .let [start (injection sample) - == (comparison n.=)]] - (_.test "Right identity." - (== start - (|> start _//disjoint (_//each _//out)))))) - -(def (associativity injection comparison (open "_//[0]")) - (All (_ f) (-> (Injection f) (Comparison f) (CoMonad f) Test)) - (do [! random.monad] - [sample random.nat - increase (at ! each (function (_ diff) - (|>> _//out (n.+ diff))) - random.nat) - decrease (at ! each (function (_ diff) - (|>> _//out(n.- diff))) - random.nat) - .let [start (injection sample) - == (comparison n.=)]] - (_.test "Associativity." - (== (|> start _//disjoint (_//each (|>> _//disjoint (_//each increase) decrease))) - (|> start _//disjoint (_//each increase) _//disjoint (_//each decrease)))))) - -(def .public (spec injection comparison subject) +(def .public (spec injection comparison it) (All (_ f) (-> (Injection f) (Comparison f) (CoMonad f) Test)) (<| (_.for [/.CoMonad]) + (do [! random.monad] + [.let [(open "/#[0]") it] + sample random.nat + increase (at ! each (function (_ diff) + (|>> /#out (n.+ diff))) + random.nat) + decrease (at ! each (function (_ diff) + (|>> /#out (n.- diff))) + random.nat) + morphism (at ! each (function (_ diff) + (|>> /#out (n.+ diff))) + random.nat) + .let [start (injection sample) + == (comparison n.=)]]) (all _.and - (..left_identity injection subject) - (..right_identity injection comparison subject) - (..associativity injection comparison subject) + (_.for [/.functor] + (functorS.spec injection comparison (the /.functor it))) + + (_.coverage [/.disjoint /.out] + (let [left_identity! + (n.= (morphism start) + (|> start /#disjoint (/#each morphism) /#out)) + + right_identity! + (== start + (|> start /#disjoint (/#each /#out))) + + associativity! + (== (|> start /#disjoint (/#each (|>> /#disjoint (/#each increase) decrease))) + (|> start /#disjoint (/#each increase) /#disjoint (/#each decrease)))] + (and left_identity! + right_identity! + associativity!))) ))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index f00cf0abc..d2af0e624 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -1274,6 +1274,6 @@ 100)] (<| io.io _.run! - (_.times times) + (_.times times _.announce_success) ..test )))) diff --git a/stdlib/source/test/lux/test/property.lux b/stdlib/source/test/lux/test/property.lux index dfaaddac5..f5754958a 100644 --- a/stdlib/source/test/lux/test/property.lux +++ b/stdlib/source/test/lux/test/property.lux @@ -62,7 +62,7 @@ /.Test (all /.and (do [! random.monad] - [times_unit_test (/.times 0 (/.test "" true))] + [times_unit_test (/.times 0 /.ignore_success (/.test "" true))] (in (do async.monad [[tally error] times_unit_test] (unit.coverage [/.must_try_test_at_least_once] @@ -73,7 +73,7 @@ [expected (at ! each (|>> (n.% 10) ++) random.nat) .let [counter (is (Atom Nat) (atom.atom 0))] - times_unit_test (<| (/.times expected) + times_unit_test (<| (/.times expected /.ignore_success) (do ! [_ (in []) .let [_ (io.run! (atom.update! ++ counter))]] @@ -85,6 +85,9 @@ (and (n.= expected actual) (n.= 1 (the tally.#successes tally)) (n.= 0 (the tally.#failures tally))))))) + (/.coverage [/.Success_Policy /.ignore_success /.announce_success] + (and (not /.ignore_success) + /.announce_success)) )) (def in_parallel diff --git a/stdlib/source/test/lux/world/net.lux b/stdlib/source/test/lux/world/net.lux index 08c56fa4b..885a918e7 100644 --- a/stdlib/source/test/lux/world/net.lux +++ b/stdlib/source/test/lux/world/net.lux @@ -21,6 +21,7 @@ ["[1][0]" uri ["[1]/[0]" encoding] ["[1]/[0]" scheme] + ["[1]/[0]" port] ["[1]/[0]" path] ["[1]/[0]" query]]]) @@ -32,8 +33,6 @@ (all _.and (_.coverage [/.Host] true) - (_.coverage [/.Port] - true) (_.coverage [/.URL] true) (_.coverage [/.Address] @@ -50,6 +49,7 @@ /uri/encoding.test /uri/scheme.test + /uri/port.test /uri/path.test /uri/query.test ))) diff --git a/stdlib/source/test/lux/world/net/uri/port.lux b/stdlib/source/test/lux/world/net/uri/port.lux new file mode 100644 index 000000000..14ffa5059 --- /dev/null +++ b/stdlib/source/test/lux/world/net/uri/port.lux @@ -0,0 +1,177 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [data + [collection + ["[0]" list] + ["[0]" set]]] + [math + ["[0]" random (.only Random)] + [number + ["[0]" nat]]] + [test + ["_" property (.only Test)]]]] + [\\library + ["[0]" /]]) + +(def .public test + Test + (<| (_.covering /._) + (do [! random.monad] + []) + (`` (all _.and + (with_expansions [ (these /.echo_protocol + /.discard_protocol + /.daytime_protocol + /.quote_of_the_day + /.message_send_protocol + /.character_generator_protocol + /.file_transfer_protocol_data_transfer + /.file_transfer_protocol_control + /.telnet + /.simple_mail_transfer_protocol + /.time_protocol + /.host_name_server_protocol + /.whois + /.domain_name_system + /.gopher + /.finger + /.hypertext_transfer_protocol + /.kerberos + + /.digital_imaging_and_communications_in_medicine + /.remote_user_telnet_service + /.post_office_protocol_2 + /.post_office_protocol_3 + /.open_network_computing_remote_procedure_call + /.simple_file_transfer_protocol + /.network_news_transfer_protocol + /.network_time_protocol + /.internet_message_access_protocol + /.simple_gateway_monitoring_protocol + /.structured_query_language + /.simple_network_management_protocol + /.simple_network_management_protocol_trap + /.secure_neighbor_discovery + /.x_display_manager_control_protocol + /.border_gateway_protocol + /.internet_relay_chat + /.snmp_unix_multiplexer + + /.border_gateway_multicast_protocol + + /.precision_time_protocol_event_messages + /.precision_time_protocol_general_messages + /.lightweight_directory_access_protocol + + /.uninterruptible_power_supply + /.service_location_protocol + /.hypertext_transfer_protocol_secure + /.simple_network_paging_protocol + /.kerberos_change/set_password + + /.remote_procedure_call + /.real_time_streaming_protocol + /.dynamic_host_configuration_protocol/6_client + /.dynamic_host_configuration_protocol/6_server + /.network_news_transfer_protocol_secure + + /.internet_printing_protocol + /.lightweight_directory_access_protocol_secure + /.multicast_source_discovery_protocol + /.label_distribution_protocol + /.application_configuration_access_protocol + /.optimized_link_state_routing_protocol + + /.extensible_provisioning_protocol + /.link_management_protocol + /.secure_internet_live_conferencing_protocol + /.kerberos_administration + + /.certificate_management_protocol + /.network_configuration_protocol/ssh + /.network_configuration_protocol/beep + /.network_configuration_protocol/soap/https + /.network_configuration_protocol/soap/beep + + /.file_transfer_protocol_secure_data_transfer + /.file_transfer_protocol_secure_control + /.telnet/tls + /.internet_message_access_protocol_secure + /.post_office_protocol_3_secure)] + (_.coverage [] + (let [options (list ) + uniques (set.of_list nat.hash options)] + (nat.= (list.size options) + (set.size uniques))))) + (,, (with_template [ ] + [(_.coverage [] + (same? ))] + + [/.file_transfer_protocol_data_transfer /.ftp_data_transfer] + [/.file_transfer_protocol_control /.ftp_control] + [/.simple_mail_transfer_protocol /.smtp] + [/.domain_name_system /.dns] + [/.hypertext_transfer_protocol /.http] + + [/.digital_imaging_and_communications_in_medicine /.dicom] + [/.remote_user_telnet_service /.rtelnet] + [/.post_office_protocol_2 /.pop2] + [/.post_office_protocol_3 /.pop3] + [/.open_network_computing_remote_procedure_call /.onc_rpc] + [/.simple_file_transfer_protocol /.simple_ftp] + [/.network_news_transfer_protocol /.nntp] + [/.network_time_protocol /.ntp] + [/.internet_message_access_protocol /.imap] + [/.simple_gateway_monitoring_protocol /.sgmp] + [/.structured_query_language /.sql] + [/.simple_network_management_protocol /.snmp] + [/.simple_network_management_protocol_trap /.snmp_trap] + [/.secure_neighbor_discovery /.send] + [/.x_display_manager_control_protocol /.xdmcp] + [/.border_gateway_protocol /.bgp] + [/.internet_relay_chat /.irc] + [/.snmp_unix_multiplexer /.smux] + + [/.border_gateway_multicast_protocol /.bgmp] + + [/.precision_time_protocol_event_messages /.ptp_event_messages] + [/.precision_time_protocol_general_messages /.ptp_general_messages] + [/.lightweight_directory_access_protocol /.ldap] + + [/.uninterruptible_power_supply /.ups] + [/.service_location_protocol /.slp] + [/.hypertext_transfer_protocol_secure /.https] + [/.simple_network_paging_protocol /.snpp] + + [/.remote_procedure_call /.rpc] + [/.real_time_streaming_protocol /.rtsp] + [/.dynamic_host_configuration_protocol/6_client /.dhcp/6_client] + [/.dynamic_host_configuration_protocol/6_server /.dhcp/6_server] + [/.network_news_transfer_protocol_secure /.nntps] + + [/.internet_printing_protocol /.ipp] + [/.lightweight_directory_access_protocol_secure /.ldaps] + [/.multicast_source_discovery_protocol /.msdp] + [/.label_distribution_protocol /.ldp] + [/.application_configuration_access_protocol /.acap] + [/.optimized_link_state_routing_protocol /.olsr] + + [/.extensible_provisioning_protocol /.epp] + [/.link_management_protocol /.lmp] + [/.secure_internet_live_conferencing_protocol /.silc] + + [/.certificate_management_protocol /.cmp] + [/.network_configuration_protocol/ssh /.netconf/ssh] + [/.network_configuration_protocol/beep /.netconf/beep] + [/.network_configuration_protocol/soap/https /.netconf/soap/https] + [/.network_configuration_protocol/soap/beep /.netconf/soap/beep] + + [/.file_transfer_protocol_secure_data_transfer /.ftps_data_transfer] + [/.file_transfer_protocol_secure_control /.ftps_control] + [/.internet_message_access_protocol_secure /.imaps] + [/.post_office_protocol_3_secure /.pop3s] + )) + )))) diff --git a/stdlib/source/test/lux/world/net/uri/scheme.lux b/stdlib/source/test/lux/world/net/uri/scheme.lux index c91c49fbf..868f2cddf 100644 --- a/stdlib/source/test/lux/world/net/uri/scheme.lux +++ b/stdlib/source/test/lux/world/net/uri/scheme.lux @@ -134,30 +134,30 @@ [/.ftp /.file_transfer_protocol] [/.http /.hypertext_transfer_protocol] - [/.https /.secure_hypertext_transfer_protocol] + [/.https /.hypertext_transfer_protocol_secure] [/.imap /.internet_message_access_protocol] [/.ipp /.internet_printing_protocol] - [/.ipps /.secure_internet_printing_protocol] + [/.ipps /.internet_printing_protocol_secure] [/.irc /.internet_relay_chat] - [/.ircs /.secure_internet_relay_chat] + [/.ircs /.internet_relay_chat_secure] [/.ldap /.lightweight_directory_access_protocol] - [/.ldaps /.secure_lightweight_directory_access_protocol] + [/.ldaps /.lightweight_directory_access_protocol_secure] [/.pop /.post_office_protocol] [/.sip /.session_initiation_protocol] - [/.sips /.secure_session_initiation_protocol] + [/.sips /.session_initiation_protocol_secure] [/.sms /.short_message_service] [/.snmp /.simple_network_management_protocol] [/.ssh /.secure_shell_protocol] [/.stun /.session_traversal_utilities_for_nat] - [/.stuns /.secure_session_traversal_utilities_for_nat] + [/.stuns /.session_traversal_utilities_for_nat_secure] [/.turn /.traversal_using_relays_around_nat] - [/.turns /.secure_traversal_using_relays_around_nat] + [/.turns /.traversal_using_relays_around_nat_secure] [/.xmpp /.extensible_messaging_and_presence_protocol])) )))) -- cgit v1.2.3