diff options
32 files changed, 1118 insertions, 554 deletions
diff --git a/licentia/commands.md b/licentia/commands.md index 58f3cf09b..b852e22cf 100644 --- a/licentia/commands.md +++ b/licentia/commands.md @@ -3,15 +3,8 @@ ``` ## Develop cd ~/lux/licentia/ \ -&& lein clean \ -&& lein lux auto build - -cd ~/lux/licentia/ \ && lux clean \ -&& time lux build - -cd ~/lux/licentia/ \ -&& time lux test +&& lux auto build ``` ## Test @@ -19,8 +12,8 @@ cd ~/lux/licentia/ \ ``` ## Develop cd ~/lux/licentia/ \ -&& lein clean \ -&& lein lux auto test +&& lux clean \ +&& lux auto test ``` ## Run diff --git a/licentia/project.lux b/licentia/project.lux index 5ef61dd16..6c025c241 100644 --- a/licentia/project.lux +++ b/licentia/project.lux @@ -10,6 +10,5 @@ #dependencies [["com.github.luxlang" "stdlib" "0.6.0-SNAPSHOT" "jar"] ["com.github.luxlang" "lux-jvm" "0.6.0-SNAPSHOT" "jar"]] - #target "target" #program "program/licentia" #test "test/licentia"} diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux index e6bd713f7..615e7a722 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux @@ -51,6 +51,9 @@ (#///analysis.Primitive analysis') (phase\wrap (#/.Primitive (..primitive analysis'))) + (#///analysis.Reference reference) + (phase\wrap (#/.Reference reference)) + (#///analysis.Structure structure) (/.with_currying? false (case structure @@ -64,9 +67,6 @@ (monad.map phase.monad optimization') (phase\map (|>> /.tuple))))) - (#///analysis.Reference reference) - (phase\wrap (#/.Reference reference)) - (#///analysis.Case inputA branchesAB+) (/.with_currying? false (/case.synthesize optimization branchesAB+ archive inputA)) diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux index c308d49c0..7c5d31bf3 100644 --- a/stdlib/source/lux/type/check.lux +++ b/stdlib/source/lux/type/check.lux @@ -20,7 +20,7 @@ ["n" nat ("#\." decimal)]]]] ["." // ("#\." equivalence)]) -(template: (!n/= reference subject) +(template: (!n\= reference subject) ("lux i64 =" reference subject)) (template: (!text\= reference subject) @@ -53,16 +53,16 @@ (type: #export Var Nat) -(type: #export Assumption +(type: Assumption [Type Type]) (type: #export (Check a) (-> Type_Context (Try [Type_Context a]))) -(type: #export (Checker a) +(type: (Checker a) (-> (List Assumption) a a (Check (List Assumption)))) -(type: #export Type_Vars +(type: Type_Vars (List [Var (Maybe Type)])) (structure: #export functor @@ -134,7 +134,7 @@ (case plist (#.Cons [var_id var_type] plist') - (if (!n/= id var_id) + (if (!n\= id var_id) (#.Some var_type) (var::get id plist')) @@ -149,7 +149,7 @@ (#.Cons [var_id var_type] plist') - (if (!n/= id var_id) + (if (!n\= id var_id) (#.Cons [var_id value] plist') (#.Cons [var_id var_type] @@ -291,12 +291,15 @@ _ (throw ..invalid_type_application [funcT argT])))) -(type: #export Ring (Set Var)) +(type: Ring + (Set Var)) -(def: empty_ring Ring (set.new n.hash)) +(def: empty_ring + Ring + (set.new n.hash)) ## TODO: Optimize this by not using sets anymore. -(def: #export (ring start) +(def: (ring start) (-> Var (Check Ring)) (function (_ context) (loop [current start @@ -305,7 +308,7 @@ (#.Some (#.Some type)) (case type (#.Var post) - (if (!n/= start post) + (if (!n\= start post) (#try.Success [context output]) (recur post (set.add post output))) @@ -390,7 +393,7 @@ ## TODO: "check_vars" can be optimized... (def: (check_vars check' assumptions idE idA) (-> (Checker Type) (Checker Var)) - (if (!n/= idE idA) + (if (!n\= idE idA) (check\wrap assumptions) (do {! ..monad} [ebound (attempt (peek idE)) @@ -454,6 +457,10 @@ _ (check' assumptions etype atype)))))) +(def: silent_failure! + (All [a] (Check a)) + (..fail "")) + ## TODO: "check_apply" can be optimized... (def: (check_apply check' assumptions expected actual) (-> (Checker Type) (Checker [Type Type])) @@ -461,9 +468,9 @@ [actual_input actual_function] actual] (case [expected_function actual_function] [(#.Ex exE) (#.Ex exA)] - (if (!n/= exE exA) + (if (!n\= exE exA) (check' assumptions expected_input actual_input) - (fail "")) + ..silent_failure!) [(#.UnivQ _ _) (#.Ex _)] (do ..monad @@ -493,7 +500,7 @@ [(#.Var id) _] (function (_ context) (case ((do ..monad - [expected_function' (read! id)] + [expected_function' (..read! id)] (check' assumptions (#.Apply expected_input expected_function') (#.Apply actual))) context) (#try.Success output) @@ -539,20 +546,20 @@ context))) _ - (fail "")))) + ..silent_failure!))) (def: (with exception parameter check) (All [e a] (-> (Exception e) e (Check a) (Check a))) (|>> check (exception.with exception parameter))) ## TODO: "check'" can be optimized... -(def: #export (check' assumptions expected actual) +(def: (check' assumptions expected actual) {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."} (Checker Type) (if (for {@.php false} ## TODO: Remove this once JPHP is gone. (is? expected actual)) (check\wrap assumptions) - (with type_check_failed [expected actual] + (with ..type_check_failed [expected actual] (case [expected actual] [(#.Var idE) (#.Var idA)] (check_vars check' assumptions idE idA) @@ -625,8 +632,8 @@ (recur assumptions' e_tail a_tail)) _ - (fail ""))) - (fail "")) + ..silent_failure!)) + ..silent_failure!) (^template [<compose>] [[(<compose> eL eR) (<compose> aL aR)] @@ -642,9 +649,9 @@ (check' assumptions eO aO)) [(#.Ex e!id) (#.Ex a!id)] - (if (!n/= e!id a!id) + (if (!n\= e!id a!id) (check\wrap assumptions) - (fail "")) + ..silent_failure!) [(#.Named _ ?etype) _] (check' assumptions ?etype actual) @@ -653,7 +660,7 @@ (check' assumptions expected ?atype) _ - (fail ""))))) + ..silent_failure!)))) (def: #export (check expected actual) {#.doc "Type-check to ensure that the 'expected' type subsumes the 'actual' type."} @@ -663,7 +670,7 @@ (def: #export (checks? expected actual) {#.doc "A simple type-checking function that just returns a yes/no answer."} (-> Type Type Bit) - (case (run fresh_context (check' (list) expected actual)) + (case (..run ..fresh_context (..check' (list) expected actual)) (#try.Failure _) false diff --git a/stdlib/source/lux/world/program.lux b/stdlib/source/lux/world/program.lux index f04ef63dd..ae0c6d840 100644 --- a/stdlib/source/lux/world/program.lux +++ b/stdlib/source/lux/world/program.lux @@ -3,11 +3,12 @@ ["@" target] ["." ffi (#+ import:)] [abstract - ["." monad (#+ do)]] + ["." monad (#+ Monad do)]] [control ["." function] ["." io (#+ IO)] - ["." try] + ["." try (#+ Try)] + ["." exception (#+ exception:)] [concurrency ["." atom] ["." promise (#+ Promise)]] @@ -19,9 +20,11 @@ ["." text ["%" format (#+ format)]] [collection - ["." array (#+ Array) ("#\." fold)] + ["." array (#+ Array)] ["." dictionary (#+ Dictionary)] ["." list ("#\." functor)]]] + [macro + ["." template]] [math [number ["i" int]]] @@ -31,9 +34,15 @@ [file (#+ Path)] [shell (#+ Exit)]]) +(exception: #export (unknown_environment_variable {name Text}) + (exception.report + ["Name" (%.text name)])) + (signature: #export (Program !) - (: (-> Any (! Environment)) - environment) + (: (-> Any (! (List Text))) + available_variables) + (: (-> Text (! (Try Text))) + variable) (: (-> Any (! Path)) home) (: (-> Any (! Path)) @@ -41,24 +50,50 @@ (: (-> Exit (! Nothing)) exit)) -(def: #export (async program) - (-> (Program IO) (Program Promise)) - (structure - (def: environment - (|>> (\ program environment) promise.future)) - (def: home - (|>> (\ program home) promise.future)) - (def: directory - (|>> (\ program directory) promise.future)) - (def: exit - (|>> (\ program exit) promise.future)))) +(def: #export (environment monad program) + (All [!] (-> (Monad !) (Program !) (! Environment))) + (do {! monad} + [variables (\ program available_variables []) + entries (monad.map ! (function (_ name) + (\ ! map (|>> [name]) (\ program variable name))) + variables)] + (wrap (|> entries + (list.all (function (_ [name value]) + (case value + (#try.Success value) + (#.Some [name value]) + + (#try.Failure _) + #.None))) + (dictionary.from_list text.hash))))) + +(`` (structure: #export (async program) + (-> (Program IO) (Program Promise)) + + (~~ (template [<method>] + [(def: <method> + (|>> (\ program <method>) promise.future))] + + [available_variables] + [variable] + [home] + [directory] + [exit] + )))) (def: #export (mock environment home directory) (-> Environment Path Path (Program IO)) (let [@dead? (atom.atom false)] (structure - (def: environment - (function.constant (io.io environment))) + (def: available_variables + (function.constant (io.io (dictionary.keys environment)))) + (def: (variable name) + (io.io (case (dictionary.get name environment) + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name])))) (def: home (function.constant (io.io home))) (def: directory @@ -71,11 +106,6 @@ (with_expansions [<jvm> (as_is (import: java/lang/String) - (import: (java/util/Map$Entry k v) - ["#::." - (getKey [] k) - (getValue [] v)]) - (import: (java/util/Iterator a) ["#::." (hasNext [] boolean) @@ -87,35 +117,21 @@ (import: (java/util/Map k v) ["#::." - (entrySet [] (java/util/Set (java/util/Map$Entry k v)))]) + (keySet [] (java/util/Set k))]) (import: java/lang/System ["#::." (#static getenv [] (java/util/Map java/lang/String java/lang/String)) + (#static getenv #as resolveEnv [java/lang/String] #io #? java/lang/String) (#static getProperty [java/lang/String] #? java/lang/String) (#static exit [int] #io void)]) - (def: (jvm\\consume f iterator) - (All [a b] (-> (-> a b) (java/util/Iterator a) (List b))) + (def: (jvm\\consume iterator) + (All [a] (-> (java/util/Iterator a) (List a))) (if (java/util/Iterator::hasNext iterator) - (#.Cons (f (java/util/Iterator::next iterator)) - (jvm\\consume f iterator)) + (#.Cons (java/util/Iterator::next iterator) + (jvm\\consume iterator)) #.Nil)) - - (def: (jvm\\to_kv entry) - (All [k v] (-> (java/util/Map$Entry k v) [k v])) - [(java/util/Map$Entry::getKey entry) - (java/util/Map$Entry::getValue entry)]) - - (def: jvm\\environment - (IO Environment) - (with_expansions [<jvm> (as_is (io.io (|> (java/lang/System::getenv) - java/util/Map::entrySet - java/util/Set::iterator - (..jvm\\consume ..jvm\\to_kv) - (dictionary.from_list text.hash))))] - (for {@.old <jvm> - @.jvm <jvm>}))) )] (for {@.old (as_is <jvm>) @.jvm (as_is <jvm>) @@ -189,7 +205,7 @@ (import: os/environ ["#::." (#static keys [] #io (Array ffi.String)) - (#static get [ffi.String] #io ffi.String)])) + (#static get [ffi.String] #io #? ffi.String)])) @.lua (as_is (ffi.import: LuaFile ["#::." (read [ffi.String] #io #? ffi.String) @@ -220,7 +236,7 @@ @.ruby (as_is (ffi.import: Env #as RubyEnv ["#::." (#static keys [] (Array Text)) - (#static fetch [Text] Text)]) + (#static fetch [Text] #io #? Text)]) (ffi.import: "fileutils" FileUtils #as RubyFileUtils ["#::." @@ -234,85 +250,106 @@ ["#::." (#static exit [Int] #io Nothing)])) - @.php - (as_is (ffi.import: (exit [Int] #io Nothing)) - ## https://www.php.net/manual/en/function.exit.php - (ffi.import: (getcwd [] #io ffi.String)) - ## https://www.php.net/manual/en/function.getcwd.php - (ffi.import: (getenv #as getenv/1 [ffi.String] #io ffi.String)) - (ffi.import: (getenv #as getenv/0 [] #io (Array ffi.String))) - ## https://www.php.net/manual/en/function.getenv.php - ## https://www.php.net/manual/en/function.array-keys.php - (ffi.import: (array_keys [(Array ffi.String)] (Array ffi.String))) - ) - - @.scheme - (as_is (ffi.import: (exit [Int] #io Nothing)) - ## https://srfi.schemers.org/srfi-98/srfi-98.html - (abstract: Pair Any) - (abstract: PList Any) - (ffi.import: (get-environment-variables [] #io PList)) - (ffi.import: (car [Pair] Text)) - (ffi.import: (cdr [Pair] Text)) - (ffi.import: (car #as head [PList] Pair)) - (ffi.import: (cdr #as tail [PList] PList)))} + ## @.php + ## (as_is (ffi.import: (exit [Int] #io Nothing)) + ## ## https://www.php.net/manual/en/function.exit.php + ## (ffi.import: (getcwd [] #io ffi.String)) + ## ## https://www.php.net/manual/en/function.getcwd.php + ## (ffi.import: (getenv #as getenv/1 [ffi.String] #io ffi.String)) + ## (ffi.import: (getenv #as getenv/0 [] #io (Array ffi.String))) + ## ## https://www.php.net/manual/en/function.getenv.php + ## ## https://www.php.net/manual/en/function.array-keys.php + ## (ffi.import: (array_keys [(Array ffi.String)] (Array ffi.String))) + ## ) + + ## @.scheme + ## (as_is (ffi.import: (exit [Int] #io Nothing)) + ## ## https://srfi.schemers.org/srfi-98/srfi-98.html + ## (abstract: Pair Any) + ## (abstract: PList Any) + ## (ffi.import: (get-environment-variables [] #io PList)) + ## (ffi.import: (car [Pair] Text)) + ## (ffi.import: (cdr [Pair] Text)) + ## (ffi.import: (car #as head [PList] Pair)) + ## (ffi.import: (cdr #as tail [PList] PList))) + } (as_is))) (structure: #export default (Program IO) - (def: (environment _) - (with_expansions [<jvm> ..jvm\\environment] + (def: (available_variables _) + (with_expansions [<jvm> (io.io (|> (java/lang/System::getenv) + java/util/Map::keySet + java/util/Set::iterator + ..jvm\\consume))] (for {@.old <jvm> @.jvm <jvm> @.js (io.io (if ffi.on_node_js? (case (ffi.constant Object [process env]) (#.Some process/env) - (array\fold (function (_ entry environment) - (<| (maybe.default environment) - (do maybe.monad - [variable (array.read 0 entry) - value (array.read 1 entry)] - (wrap (dictionary.put variable value environment))))) - environment.empty - (Object::entries [process/env])) + (|> (Object::entries [process/env]) + array.to_list + (list\map (|>> (array.read 0) maybe.assume))) #.None - (undefined)) - environment.empty)) - @.python (do {! io.monad} - [keys (os/environ::keys [])] - (monad.fold ! (function (_ variable environment) - (do ! - [value (os/environ::get [variable])] - (wrap (dictionary.put variable value environment)))) - environment.empty - (array.to_list keys))) + (list)) + (list))) + @.python (\ io.monad map array.to_list (os/environ::keys [])) + ## Lua offers no way to get all the environment variables available. + @.lua (io.io (list)) @.ruby (|> (RubyEnv::keys []) array.to_list (list\map (function (_ variable) [variable (RubyEnv::fetch [variable])])) (dictionary.from_list text.hash) io.io) - @.php (do io.monad - [environment (..getenv/0 [])] - (wrap (|> environment - ..array_keys - array.to_list - (list\map (function (_ variable) - [variable ("php array read" (:coerce Nat variable) environment)])) - (dictionary.from_list text.hash)))) - @.scheme (do io.monad - [input (..get-environment-variables [])] - (loop [input input - output environment.empty] - (if ("scheme object nil?" input) - (wrap output) - (let [entry (..head input)] - (recur (..tail input) - (dictionary.put (..car entry) (..cdr entry) output))))))} - ## TODO: Replace dummy implementation. - (io.io environment.empty)))) + ## @.php (do io.monad + ## [environment (..getenv/0 [])] + ## (wrap (|> environment + ## ..array_keys + ## array.to_list + ## (list\map (function (_ variable) + ## [variable ("php array read" (:coerce Nat variable) environment)])) + ## (dictionary.from_list text.hash)))) + ## @.scheme (do io.monad + ## [input (..get-environment-variables [])] + ## (loop [input input + ## output environment.empty] + ## (if ("scheme object nil?" input) + ## (wrap output) + ## (let [entry (..head input)] + ## (recur (..tail input) + ## (dictionary.put (..car entry) (..cdr entry) output)))))) + }))) + + (def: (variable name) + (template.let [(!fetch <method>) + [(do io.monad + [value (<method> name)] + (wrap (case value + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name]))))]] + (with_expansions [<jvm> (!fetch java/lang/System::resolveEnv)] + (for {@.old <jvm> + @.jvm <jvm> + @.js (io.io (if ffi.on_node_js? + (case (do maybe.monad + [process/env (ffi.constant Object [process env])] + (array.read (: Nat name) process/env)) + (#.Some value) + (#try.Success value) + + #.None + (exception.throw ..unknown_environment_variable [name])) + (exception.throw ..unknown_environment_variable [name]))) + @.python (!fetch os/environ::get) + @.lua (!fetch os/getenv) + @.ruby (!fetch RubyEnv::fetch) + })))) (def: (home _) (with_expansions [<default> (io.io "~") @@ -327,11 +364,12 @@ @.python (os/path::expanduser ["~"]) @.lua (..run_command "~" "echo ~") @.ruby (RubyDir::home []) - @.php (do io.monad - [output (..getenv/1 ["HOME"])] - (wrap (if (bit\= false (:coerce Bit output)) - "~" - output)))} + ## @.php (do io.monad + ## [output (..getenv/1 ["HOME"])] + ## (wrap (if (bit\= false (:coerce Bit output)) + ## "~" + ## output))) + } ## TODO: Replace dummy implementation. <default>))) @@ -356,11 +394,12 @@ (..run_command default "pwd") (wrap on_windows))) @.ruby (RubyFileUtils::pwd []) - @.php (do io.monad - [output (..getcwd [])] - (wrap (if (bit\= false (:coerce Bit output)) - "." - output)))} + ## @.php (do io.monad + ## [output (..getcwd [])] + ## (wrap (if (bit\= false (:coerce Bit output)) + ## "." + ## output))) + } ## TODO: Replace dummy implementation. (io.io <default>)))) @@ -381,5 +420,6 @@ @.python (os::_exit [code]) @.lua (os/exit [code]) @.ruby (RubyKernel::exit [code]) - @.php (..exit [code]) - @.scheme (..exit [code])})))) + ## @.php (..exit [code]) + ## @.scheme (..exit [code]) + })))) diff --git a/stdlib/source/program/aedifex/command/auto.lux b/stdlib/source/program/aedifex/command/auto.lux index 000384ccd..f74d3069a 100644 --- a/stdlib/source/program/aedifex/command/auto.lux +++ b/stdlib/source/program/aedifex/command/auto.lux @@ -65,7 +65,7 @@ (monad.map ! (..targets fs)) (\ ! map list.concat))] (do {! ///action.monad} - [_ (monad.map ! (\ watcher start watch.all) targets) + [_ (monad.map ! (\ watcher start watch.modification) targets) _ <call>] (loop [_ []] (do ! diff --git a/stdlib/source/program/aedifex/command/build.lux b/stdlib/source/program/aedifex/command/build.lux index e2d6f78b8..6d61475d0 100644 --- a/stdlib/source/program/aedifex/command/build.lux +++ b/stdlib/source/program/aedifex/command/build.lux @@ -23,7 +23,7 @@ [number ["i" int]]] [world - [program (#+ Program)] + ["." program (#+ Program)] ["." file (#+ Path)] ["." shell (#+ Process Shell)] ["." console (#+ Console)] @@ -76,7 +76,6 @@ (exception: #export no_available_compiler) (exception: #export no_specified_program) -(exception: #export no_specified_target) (type: #export Compiler (#JVM Dependency) @@ -169,45 +168,42 @@ (def: #export (do! console program fs shell resolution) (-> (Console Promise) (Program Promise) (file.System Promise) (Shell Promise) Resolution (Command [Compiler Path])) (function (_ profile) - (case [(get@ #///.program profile) - (get@ #///.target profile)] - [#.None _] - (promise\wrap (exception.throw ..no_specified_program [])) - - [_ #.None] - (promise\wrap (exception.throw ..no_specified_target [])) - - [(#.Some program_module) (#.Some target)] - (do promise.monad - [environment (\ program environment []) - home (\ program home []) - working_directory (\ program directory [])] - (do ///action.monad - [[resolution compiler] (promise\wrap (..compiler resolution)) - #let [[[command compiler_params] output] (case compiler - (#JVM dependency) [(///runtime.java (..path fs home dependency)) - "program.jar"] - (#JS dependency) [(///runtime.node (..path fs home dependency)) - "program.js"]) - / (\ fs separator) - cache_directory (format working_directory / target)] - _ (console.write_line ..start console) - process (!.use (\ shell execute) - [environment - working_directory - command - (list.concat (list compiler_params - (list "build") - (..plural "--library" (..libraries fs home resolution)) - (..plural "--source" (set.to_list (get@ #///.sources profile))) - (..singular "--target" cache_directory) - (..singular "--module" program_module)))]) - _ (..log_output! console process) - _ (..log_error! console process) - exit (!.use (\ process await) []) - _ (console.write_line (if (i.= shell.normal exit) - ..success - ..failure) - console)] - (wrap [compiler - (format cache_directory / output)])))))) + (let [target (get@ #///.target profile)] + (case (get@ #///.program profile) + #.None + (promise\wrap (exception.throw ..no_specified_program [])) + + (#.Some program_module) + (do promise.monad + [environment (program.environment promise.monad program) + home (\ program home []) + working_directory (\ program directory [])] + (do ///action.monad + [[resolution compiler] (promise\wrap (..compiler resolution)) + #let [[[command compiler_params] output] (case compiler + (#JVM dependency) [(///runtime.java (..path fs home dependency)) + "program.jar"] + (#JS dependency) [(///runtime.node (..path fs home dependency)) + "program.js"]) + / (\ fs separator) + cache_directory (format working_directory / target)] + _ (console.write_line ..start console) + process (!.use (\ shell execute) + [environment + working_directory + command + (list.concat (list compiler_params + (list "build") + (..plural "--library" (..libraries fs home resolution)) + (..plural "--source" (set.to_list (get@ #///.sources profile))) + (..singular "--target" cache_directory) + (..singular "--module" program_module)))]) + _ (..log_output! console process) + _ (..log_error! console process) + exit (!.use (\ process await) []) + _ (console.write_line (if (i.= shell.normal exit) + ..success + ..failure) + console)] + (wrap [compiler + (format cache_directory / output)]))))))) diff --git a/stdlib/source/program/aedifex/command/clean.lux b/stdlib/source/program/aedifex/command/clean.lux index 900de2cc4..ecb71b59d 100644 --- a/stdlib/source/program/aedifex/command/clean.lux +++ b/stdlib/source/program/aedifex/command/clean.lux @@ -8,6 +8,9 @@ ["!" capability]] [concurrency ["." promise (#+ Promise)]]] + [data + [text + ["%" format (#+ format)]]] [world ["." file (#+ Path File Directory)] ["." console (#+ Console)]]] @@ -26,27 +29,21 @@ nodes)] (wrap []))) -(def: #export success - "Success") - -(def: #export failure - "Failure: No 'target' defined for clean-up.") +(def: #export (success path) + (-> ///.Target Text) + (format "Successfully cleaned target directory: " path)) (def: #export (do! console fs profile) (-> (Console Promise) (file.System Promise) (Command Any)) - (case (get@ #///.target profile) - (#.Some target) - (do {! ///action.monad} - [target (: (Promise (Try (Directory Promise))) - (!.use (\ fs directory) target)) - _ (loop [root target] - (do ! - [_ (..clean_files! root) - subs (: (Promise (Try (List (Directory Promise)))) - (!.use (\ root directories) [])) - _ (monad.map ! recur subs)] - (!.use (\ root discard) [])))] - (console.write_line ..success console)) - - #.None - (console.write_line ..failure console))) + (do {! ///action.monad} + [#let [target (get@ #///.target profile)] + root (: (Promise (Try (Directory Promise))) + (!.use (\ fs directory) target)) + _ (loop [root root] + (do ! + [_ (..clean_files! root) + subs (: (Promise (Try (List (Directory Promise)))) + (!.use (\ root directories) [])) + _ (monad.map ! recur subs)] + (!.use (\ root discard) [])))] + (console.write_line (..success target) console))) diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux index 6546045a4..5ec42be78 100644 --- a/stdlib/source/program/aedifex/command/deploy.lux +++ b/stdlib/source/program/aedifex/command/deploy.lux @@ -52,6 +52,9 @@ ["#/." extension (#+ Extension)] ["#/." type]]]]) +(def: #export success + "Successfully deployed the project.") + (def: #export (do! console repository fs artifact profile) (-> (Console Promise) (Repository Promise) (file.System Promise) Artifact (Command Any)) (do {! ///action.monad} @@ -73,4 +76,4 @@ #///package.pom [pom pom_data (///dependency/status.verified pom_data)]}))] - (console.write_line //clean.success console))) + (console.write_line ..success console))) diff --git a/stdlib/source/program/aedifex/command/deps.lux b/stdlib/source/program/aedifex/command/deps.lux index d699de528..36a129bd1 100644 --- a/stdlib/source/program/aedifex/command/deps.lux +++ b/stdlib/source/program/aedifex/command/deps.lux @@ -45,7 +45,6 @@ [cached (|> (dictionary.keys cache) (list\fold dictionary.remove resolution) (///dependency/deployment.all local)) - _ (console.write_line //clean.success console) _ (console.write_line (exception.report ["Local successes" (exception.enumerate ..format local_successes)] ["Local failures" (exception.enumerate ..format local_failures)] diff --git a/stdlib/source/program/aedifex/command/install.lux b/stdlib/source/program/aedifex/command/install.lux index 375e803ce..2e5ce6d89 100644 --- a/stdlib/source/program/aedifex/command/install.lux +++ b/stdlib/source/program/aedifex/command/install.lux @@ -45,6 +45,9 @@ ["#." artifact (#+ Artifact) ["#/." type]]]]) +(def: #export success + "Successfully installed the project locally.") + (def: #export failure "Failure: No 'identity' defined for the project.") @@ -66,7 +69,7 @@ #///package.pom [pom pom_data (///dependency/status.verified pom_data)]}))] - (console.write_line //clean.success console)) + (console.write_line ..success console)) _ (console.write_line ..failure console))) diff --git a/stdlib/source/program/aedifex/command/pom.lux b/stdlib/source/program/aedifex/command/pom.lux index 7ca26c311..16d036718 100644 --- a/stdlib/source/program/aedifex/command/pom.lux +++ b/stdlib/source/program/aedifex/command/pom.lux @@ -25,6 +25,9 @@ ["#." action (#+ Action)] ["#." pom]]]) +(def: #export success + (format "Successfully created POM file: " ///pom.file)) + (def: #export (do! console fs profile) (-> (Console Promise) (file.System Promise) (Command Path)) (do ///action.monad @@ -35,5 +38,5 @@ (\ xml.codec encode) (\ utf8.codec encode) (!.use (\ file over_write))) - _ (console.write_line //clean.success console)] + _ (console.write_line ..success console)] (wrap ///pom.file))) diff --git a/stdlib/source/program/aedifex/command/test.lux b/stdlib/source/program/aedifex/command/test.lux index e717b7cd6..f3ab6c12a 100644 --- a/stdlib/source/program/aedifex/command/test.lux +++ b/stdlib/source/program/aedifex/command/test.lux @@ -14,7 +14,7 @@ [number ["i" int]]] [world - [program (#+ Program)] + ["." program (#+ Program)] ["." file] ["." shell (#+ Shell)] ["." console (#+ Console)]]] @@ -35,7 +35,7 @@ (def: #export (do! console program fs shell resolution profile) (-> (Console Promise) (Program Promise) (file.System Promise) (Shell Promise) Resolution (Command Any)) (do promise.monad - [environment (\ program environment []) + [environment (program.environment promise.monad program) working_directory (\ program directory [])] (do ///action.monad [[compiler program] (//build.do! console program fs shell resolution diff --git a/stdlib/source/program/aedifex/dependency/deployment.lux b/stdlib/source/program/aedifex/dependency/deployment.lux index 963602494..0fdf7956f 100644 --- a/stdlib/source/program/aedifex/dependency/deployment.lux +++ b/stdlib/source/program/aedifex/dependency/deployment.lux @@ -23,7 +23,7 @@ [format ["." xml]]] [time - ["." instant]] + ["." instant (#+ Instant)]] [world [program (#+ Program)] ["." file (#+ Path File Directory)]]] @@ -32,6 +32,7 @@ ["#." hash (#+ Hash SHA-1 MD5)] ["#." package (#+ Package)] ["#." artifact (#+ Artifact) + ["#/." time] ["#/." type] ["#/." extension (#+ Extension)] ["#/." versioning] @@ -40,7 +41,7 @@ ["#/." value]]]] ["#." metadata ["#/." artifact] - ["#/." snapshot]] + ["#/." snapshot (#+ Metadata)]] ["#." dependency (#+ Dependency) [resolution (#+ Resolution)] ["#/." status (#+ Status)]] @@ -93,6 +94,35 @@ (#///dependency/status.Verified _) (list <sha-1> <md5>))))) +(def: (update_snapshot [artifact type] now snapshot) + (-> Dependency Instant Metadata (Try Metadata)) + (do try.monad + [now (: (Try ///artifact/time.Time) + (///artifact/time.from_instant now)) + #let [version_template (get@ #///artifact.version artifact) + snapshot (|> snapshot + (update@ [#///metadata/snapshot.versioning #///artifact/versioning.snapshot] + (function (_ snapshot) + (case snapshot + #///artifact/snapshot.Local + #///artifact/snapshot.Local + + (#///artifact/snapshot.Remote [_ build]) + (#///artifact/snapshot.Remote [now (inc build)])))) + (set@ [#///metadata/snapshot.versioning #///artifact/versioning.last_updated] now)) + versioning_snapshot (get@ [#///metadata/snapshot.versioning #///artifact/versioning.snapshot] snapshot)]] + (wrap (|> snapshot + (set@ [#///metadata/snapshot.versioning #///artifact/versioning.versions] + (list {#///artifact/snapshot/version.extension type + #///artifact/snapshot/version.value (///artifact/snapshot/version/value.format + {#///artifact/snapshot/version/value.version version_template + #///artifact/snapshot/version/value.snapshot versioning_snapshot}) + #///artifact/snapshot/version.updated now})) + ## (set@ [#///metadata/snapshot.versioning #///artifact/versioning.snapshot] + ## (list\compose (..artifacts type (product.right (get@ #///package.library package))) + ## (..artifacts ///artifact/type.pom (product.right (get@ #///package.pom package))))) + )))) + (def: #export (one repository [artifact type] package) (-> (Repository Promise) Dependency Package (Promise (Try Artifact))) (do {! promise.monad} @@ -109,28 +139,8 @@ status])) snapshot (///metadata/snapshot.read repository artifact) - #let [snapshot (|> snapshot - (update@ [#///metadata/snapshot.versioning #///artifact/versioning.snapshot] - (function (_ snapshot) - (case snapshot - #///artifact/snapshot.Local - #///artifact/snapshot.Local - - (#///artifact/snapshot.Remote [_ build]) - (#///artifact/snapshot.Remote [now (inc build)])))) - (set@ [#///metadata/snapshot.versioning #///artifact/versioning.last_updated] now)) - versioning_snapshot (get@ [#///metadata/snapshot.versioning #///artifact/versioning.snapshot] snapshot)] - _ (|> snapshot - (set@ [#///metadata/snapshot.versioning #///artifact/versioning.versions] - (list {#///artifact/snapshot/version.extension type - #///artifact/snapshot/version.value (///artifact/snapshot/version/value.format - {#///artifact/snapshot/version/value.version version_template - #///artifact/snapshot/version/value.snapshot versioning_snapshot}) - #///artifact/snapshot/version.updated now})) - ## (set@ [#///metadata/snapshot.versioning #///artifact/versioning.snapshot] - ## (list\compose (..artifacts type (product.right (get@ #///package.library package))) - ## (..artifacts ///artifact/type.pom (product.right (get@ #///package.pom package))))) - (///metadata/snapshot.write repository artifact)) + snapshot (\ ! wrap (..update_snapshot [artifact type] now snapshot)) + _ (///metadata/snapshot.write repository artifact snapshot) project (///metadata/artifact.read repository artifact) _ (|> project (set@ #///metadata/artifact.versions (list version_template)) diff --git a/stdlib/source/program/aedifex/format.lux b/stdlib/source/program/aedifex/format.lux index 6fcbb2db7..7778e7641 100644 --- a/stdlib/source/program/aedifex/format.lux +++ b/stdlib/source/program/aedifex/format.lux @@ -140,7 +140,7 @@ (..on_set "repositories" (get@ #/.repositories value) code.text) (..on_set "dependencies" (get@ #/.dependencies value) ..dependency) (..on_set "sources" (get@ #/.sources value) code.text) - (..on_maybe "target" (get@ #/.target value) code.text) + (dictionary.put "target" (code.text (get@ #/.target value))) (..on_maybe "program" (get@ #/.program value) code.text) (..on_maybe "test" (get@ #/.test value) code.text) (..on_dictionary "deploy_repositories" (get@ #/.deploy_repositories value) code.text code.text) diff --git a/stdlib/source/program/aedifex/parser.lux b/stdlib/source/program/aedifex/parser.lux index 3c1b4144a..60e491dac 100644 --- a/stdlib/source/program/aedifex/parser.lux +++ b/stdlib/source/program/aedifex/parser.lux @@ -200,9 +200,10 @@ (|> (..plural input "sources" ..source) (\ ! map (set.from_list text.hash)) (<>.default (set.from_list text.hash (list /.default_source))))) - ^target (: (Parser (Maybe /.Target)) - (<>.maybe - (..singular input "target" ..target))) + ^target (: (Parser /.Target) + (|> ..target + (..singular input "target") + (<>.default /.default_target))) ^program (: (Parser (Maybe Module)) (<>.maybe (..singular input "program" ..module))) diff --git a/stdlib/source/program/aedifex/pom.lux b/stdlib/source/program/aedifex/pom.lux index f105f07b6..0d468d5f2 100644 --- a/stdlib/source/program/aedifex/pom.lux +++ b/stdlib/source/program/aedifex/pom.lux @@ -30,6 +30,9 @@ (def: project_tag "project") (def: dependencies_tag "dependencies") +(def: repositories_tag "repositories") +(def: repository_tag "repository") +(def: url_tag "url") (def: group_tag "groupId") (def: artifact_tag "artifactId") (def: version_tag "version") @@ -63,15 +66,15 @@ (def: (license [name url distribution]) (-> /.License XML) (|> (list (..property "name" name) - (..property "url" url) + (..property ..url_tag url) (..distribution distribution)) (#_.Node ["" "license"] _.attributes))) (def: repository (-> Address XML) - (|>> (..property "url") + (|>> (..property ..url_tag) list - (#_.Node ["" "repository"] _.attributes))) + (#_.Node ["" ..repository_tag] _.attributes))) (def: (dependency value) (-> Dependency XML) @@ -87,14 +90,14 @@ (comment (def: scm (-> /.SCM XML) - (|>> (..property "url") + (|>> (..property ..url_tag) list (#_.Node ["" "scm"] _.attributes))) (def: (organization [name url]) (-> /.Organization XML) (|> (list (..property "name" name) - (..property "url" url)) + (..property ..url_tag url)) (#_.Node ["" "organization"] _.attributes))) (def: (developer_organization [name url]) @@ -120,7 +123,7 @@ (def: (info value) (-> /.Info (List XML)) ($_ list\compose - (|> value (get@ #/.url) (maybe\map (..property "url")) maybe.to_list) + (|> value (get@ #/.url) (maybe\map (..property ..url_tag)) maybe.to_list) (|> value (get@ #/.description) (maybe\map (..property "description")) maybe.to_list) (|> value (get@ #/.licenses) (list\map ..license) (..group "licenses") list) (|> value (get@ #/.scm) (maybe\map ..scm) maybe.to_list) @@ -178,6 +181,21 @@ [_ (<xml>.node ["" ..dependencies_tag])] (<xml>.children (<>.some (..parse_dependency own_version parent_version))))) +(def: parse_repository + (Parser Address) + (do {! <>.monad} + [_ (<xml>.node ["" ..repository_tag])] + (<xml>.children + (do ! + [_ (<xml>.node ["" ..url_tag])] + (<xml>.children <xml>.text))))) + +(def: parse_repositories + (Parser (List Address)) + (do {! <>.monad} + [_ (<xml>.node ["" ..repositories_tag])] + (<xml>.children (<>.some ..parse_repository)))) + (def: own_version (Parser Text) (do <>.monad @@ -201,7 +219,12 @@ [dependencies (|> (..parse_dependencies own_version parent_version) <xml>.somewhere (<>.default (list))) + repositories (|> ..parse_repositories + <xml>.somewhere + (<>.default (list))) _ (<>.some <xml>.ignore)] (wrap (|> (\ /.monoid identity) (update@ #/.dependencies (function (_ empty) - (list\fold set.add empty dependencies))))))))) + (list\fold set.add empty dependencies))) + (update@ #/.repositories (function (_ empty) + (list\fold set.add empty repositories))))))))) diff --git a/stdlib/source/program/aedifex/profile.lux b/stdlib/source/program/aedifex/profile.lux index 592e221fd..98eb1c43e 100644 --- a/stdlib/source/program/aedifex/profile.lux +++ b/stdlib/source/program/aedifex/profile.lux @@ -8,7 +8,7 @@ [data ["." product] ["." maybe ("#\." monoid)] - ["." text] + ["." text ("#\." equivalence)] [collection ["." dictionary (#+ Dictionary)] ["." list ("#\." monoid)] @@ -150,7 +150,7 @@ #repositories (Set Address) #dependencies (Set dependency.Dependency) #sources (Set Source) - #target (Maybe Target) + #target Target #program (Maybe Module) #test (Maybe Module) #deploy_repositories (Dictionary Text Address)}) @@ -171,7 +171,7 @@ ## #sources set.equivalence ## #target - (maybe.equivalence text.equivalence) + text.equivalence ## #program (maybe.equivalence text.equivalence) ## #test @@ -189,7 +189,7 @@ #repositories (set.new text.hash) #dependencies (set.new dependency.hash) #sources (set.new text.hash) - #target #.None + #target ..default_target #program #.None #test #.None #deploy_repositories (dictionary.new text.hash)}) @@ -201,7 +201,9 @@ #repositories (set.union (get@ #repositories baseline) (get@ #repositories override)) #dependencies (set.union (get@ #dependencies baseline) (get@ #dependencies override)) #sources (set.union (get@ #sources baseline) (get@ #sources override)) - #target (maybe\compose (get@ #target override) (get@ #target baseline)) + #target (if (text\= ..default_target (get@ #target baseline)) + (get@ #target override) + (get@ #target baseline)) #program (maybe\compose (get@ #program override) (get@ #program baseline)) #test (maybe\compose (get@ #test override) (get@ #test baseline)) #deploy_repositories (dictionary.merge (get@ #deploy_repositories override) (get@ #deploy_repositories baseline))})) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index a6b85ccf0..557e9d22a 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -20,6 +20,8 @@ [collection ["." dictionary] ["." row (#+ Row)]]] + [time + ["." instant]] ["." world #_ ["." file (#+ File Path)] ["#/." program] @@ -71,6 +73,18 @@ (#try.Success output) (wrap output)))) +(def: (timed process) + (All [a] + (-> (Promise (Try a)) (Promise (Try a)))) + (do promise.monad + [#let [start (io.run instant.now)] + output process + #let [_ ("lux io log" (|> (io.run instant.now) + (instant.span start) + %.duration + (format "Duration: ")))]] + (wrap output))) + (def: (package! monad file_system [packager package] static archive context) (All [!] (-> (Monad !) (file.System !) [Packager Path] Static Archive Context (! (Try Any)))) (for {@.old @@ -132,6 +146,7 @@ (case service (#/cli.Compilation compilation) (<| (or_crash! "Compilation failed:") + ..timed (do (try.with promise.monad) [#let [[compilation_sources compilation_libraries compilation_target compilation_module] compilation] import (/import.import (get@ #platform.&file_system platform) compilation_libraries) diff --git a/stdlib/source/spec/lux/world/program.lux b/stdlib/source/spec/lux/world/program.lux index f7f848ed3..939445169 100644 --- a/stdlib/source/spec/lux/world/program.lux +++ b/stdlib/source/spec/lux/world/program.lux @@ -21,8 +21,8 @@ (-> (/.Program Promise) Test) (do random.monad [exit random.int] - (wrap (do promise.monad - [environment (\ subject environment []) + (wrap (do {! promise.monad} + [environment (/.environment ! subject) home (\ subject home []) directory (\ subject directory [])] (_.cover' [/.Program] diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux index b7d0d29d9..8757242c5 100644 --- a/stdlib/source/test/aedifex.lux +++ b/stdlib/source/test/aedifex.lux @@ -15,9 +15,9 @@ ["#." input] ["#." local] ["#." metadata] - ## ["#." package] - ## ["#." profile] - ## ["#." project] + ["#." package] + ["#." profile] + ["#." project] ## ["#." parser] ## ["#." pom] ## ["#." repository] @@ -43,10 +43,10 @@ /input.test /local.test /metadata.test + /package.test + /profile.test + /project.test - ## /package.test - ## /profile.test - ## /project.test ## /parser.test ## /pom.test ## /repository.test diff --git a/stdlib/source/test/aedifex/command/auto.lux b/stdlib/source/test/aedifex/command/auto.lux index c23519bcc..7ef74d2c0 100644 --- a/stdlib/source/test/aedifex/command/auto.lux +++ b/stdlib/source/test/aedifex/command/auto.lux @@ -14,7 +14,9 @@ ["!" capability]]] [data ["." text - ["%" format (#+ format)]] + ["%" format (#+ format)] + [encoding + ["." utf8]]] [collection ["." dictionary] ["." set] @@ -27,7 +29,7 @@ [console (#+ Console)] ["." shell (#+ Shell)] ["." program (#+ Program)] - ["." file (#+ Path) + ["." file (#+ Path File) ["." watch]]]] ["." // #_ ["@." version] @@ -47,28 +49,22 @@ ["#." dependency ["#/." resolution (#+ Resolution)]]]]]}) -(def: (command end_signal dummy_files) - (-> Text (List Path) - [(Atom [Nat (List Path)]) +(def: (command expected_runs end_signal dummy_file) + (-> Nat Text (File Promise) + [(Atom Nat) (-> (Console Promise) (Program Promise) (file.System Promise) (Shell Promise) Resolution (Command Any))]) - (let [@runs (: (Atom [Nat (List Path)]) - (atom.atom [0 dummy_files]))] + (let [@runs (: (Atom Nat) + (atom.atom 0))] [@runs (function (_ console program fs shell resolution profile) (do {! promise.monad} - [[_ [runs remaining_files]] (promise.future - (atom.update (function (_ [runs remaining_files]) - [(inc runs) remaining_files]) - @runs))] - (case remaining_files - #.Nil + [[_ actual_runs] (promise.future (atom.update inc @runs))] + (if (n.= expected_runs actual_runs) (wrap (#try.Failure end_signal)) - - (#.Cons head tail) (do (try.with !) - [_ (!.use (\ fs create_file) [head])] + [_ (!.use (\ dummy_file over_write) (\ utf8.codec encode (%.nat actual_runs)))] (do ! - [_ (promise.future (atom.write [runs tail] @runs))] + [_ (promise.future (atom.write actual_runs @runs))] (wrap (#try.Success [])))))))])) (def: #export test @@ -85,7 +81,7 @@ #let [empty_profile (: Profile (\ ///.monoid identity)) with_target (: (-> Profile Profile) - (set@ #///.target (#.Some target))) + (set@ #///.target target)) with_program (: (-> Profile Profile) (set@ #///.program (#.Some program))) @@ -98,15 +94,14 @@ working_directory (random.ascii/alpha 5) expected_runs (\ ! map (|>> (n.% 10) (n.max 2)) random.nat) - dummy_files (|> (random.ascii/alpha 5) - (random.set text.hash (dec expected_runs)) - (\ ! map (|>> set.to_list (list\map (|>> (format source /)))))) + dummy_path (\ ! map (|>> (format source /)) (random.ascii/alpha 5)) resolution @build.resolution] ($_ _.and (wrap (do promise.monad [verdict (do ///action.monad - [#let [[@runs command] (..command end_signal dummy_files)] - _ (!.use (\ fs create_directory) [source]) + [_ (!.use (\ fs create_directory) [source]) + dummy_file (!.use (\ fs create_file) [dummy_path]) + #let [[@runs command] (..command expected_runs end_signal dummy_file)] _ (\ watcher poll [])] (do promise.monad [outcome ((/.do! 1 watcher command) @@ -116,7 +111,7 @@ (shell.async (@build.good_shell [])) resolution profile) - [actual_runs _] (promise.future (atom.read @runs))] + actual_runs (promise.future (atom.read @runs))] (wrap (#try.Success (and (n.= expected_runs actual_runs) (case outcome (#try.Failure error) diff --git a/stdlib/source/test/aedifex/command/build.lux b/stdlib/source/test/aedifex/command/build.lux index 234343fea..7fd8c3eb3 100644 --- a/stdlib/source/test/aedifex/command/build.lux +++ b/stdlib/source/test/aedifex/command/build.lux @@ -109,7 +109,7 @@ #let [empty_profile (: Profile (\ ///.monoid identity)) with_target (: (-> Profile Profile) - (set@ #///.target (#.Some target))) + (set@ #///.target target)) with_program (: (-> Profile Profile) (set@ #///.program (#.Some program))) @@ -128,16 +128,6 @@ (#try.Failure error) (exception.match? /.no_specified_program error))))) (wrap (do promise.monad - [outcome (/.do! (@version.echo "") (program.async (program.mock environment.empty home working_directory)) fs shell ///dependency/resolution.empty - (with_program empty_profile))] - (_.cover' [/.no_specified_target] - (case outcome - (#try.Success _) - false - - (#try.Failure error) - (exception.match? /.no_specified_target error))))) - (wrap (do promise.monad [outcome (/.do! (@version.echo "") (program.async (program.mock environment.empty home working_directory)) fs shell ///dependency/resolution.empty profile)] (_.cover' [/.Compiler /.no_available_compiler] (case outcome diff --git a/stdlib/source/test/aedifex/command/clean.lux b/stdlib/source/test/aedifex/command/clean.lux index d98473259..705cca7f2 100644 --- a/stdlib/source/test/aedifex/command/clean.lux +++ b/stdlib/source/test/aedifex/command/clean.lux @@ -99,35 +99,25 @@ sub_files (..files (format sub_path /)) dummy @profile.random] - ($_ _.and - (wrap (do promise.monad - [#let [console (@version.echo "")] - verdict (do {! (try.with promise.monad)} - [_ (/.do! console fs (set@ #///.target #.None dummy))] - (\ ! map (text\= /.failure) - (!.use (\ console read_line) [])))] - (_.cover' [/.failure] - (try.default false verdict)))) - (wrap (do promise.monad - [#let [console (@version.echo "")] - verdict (do {! (try.with promise.monad)} - [_ (..create_directory! fs target_path direct_files) - _ (..create_directory! fs sub_path sub_files) - context_exists!/pre (..directory_exists? fs context) - target_exists!/pre (..assets_exist? fs target_path direct_files) - sub_exists!/pre (..assets_exist? fs sub_path sub_files) - _ (/.do! console fs (set@ #///.target (#.Some target_path) dummy)) - context_exists!/post (..directory_exists? fs context) - target_exists!/post (..assets_exist? fs target_path direct_files) - sub_exists!/post (..assets_exist? fs sub_path sub_files) - logging (!.use (\ console read_line) [])] - (wrap (and (and context_exists!/pre - context_exists!/post) - (and target_exists!/pre - (not target_exists!/post)) - (and sub_exists!/pre - (not sub_exists!/post)) - (text\= /.success logging))))] - (_.cover' [/.do! /.success] - (try.default false verdict)))) - )))) + (wrap (do promise.monad + [#let [console (@version.echo "")] + verdict (do {! (try.with promise.monad)} + [_ (..create_directory! fs target_path direct_files) + _ (..create_directory! fs sub_path sub_files) + context_exists!/pre (..directory_exists? fs context) + target_exists!/pre (..assets_exist? fs target_path direct_files) + sub_exists!/pre (..assets_exist? fs sub_path sub_files) + _ (/.do! console fs (set@ #///.target target_path dummy)) + context_exists!/post (..directory_exists? fs context) + target_exists!/post (..assets_exist? fs target_path direct_files) + sub_exists!/post (..assets_exist? fs sub_path sub_files) + logging (!.use (\ console read_line) [])] + (wrap (and (and context_exists!/pre + context_exists!/post) + (and target_exists!/pre + (not target_exists!/post)) + (and sub_exists!/pre + (not sub_exists!/post)) + (text\= (/.success target_path) logging))))] + (_.cover' [/.do! /.success] + (try.default false verdict))))))) diff --git a/stdlib/source/test/aedifex/command/deploy.lux b/stdlib/source/test/aedifex/command/deploy.lux index cc99f2e48..7e1bf166e 100644 --- a/stdlib/source/test/aedifex/command/deploy.lux +++ b/stdlib/source/test/aedifex/command/deploy.lux @@ -123,7 +123,7 @@ (\ ///hash.md5_codec decode actual_md5))) #let [succeeded! - (text\= //clean.success logging) + (text\= /.success logging) deployed_library! (\ binary.equivalence = @@ -149,5 +149,5 @@ deployed_pom! deployed_sha-1! deployed_md5!)))] - (_.cover' [/.do!] + (_.cover' [/.do! /.success] (try.default false verdict))))))) diff --git a/stdlib/source/test/aedifex/command/deps.lux b/stdlib/source/test/aedifex/command/deps.lux index 8b5e3820e..2b4898dd3 100644 --- a/stdlib/source/test/aedifex/command/deps.lux +++ b/stdlib/source/test/aedifex/command/deps.lux @@ -107,9 +107,6 @@ (set@ #///.dependencies (set.from_list ///dependency.hash (list dependee depender))) (/.do! console local (list (///repository.mock ($///dependency/resolution.single depender_artifact depender_package) [])))) - logging! (\ ///action.monad map - (text\= //clean.success) - (!.use (\ console read_line) [])) #let [had_dependee_before! (set.member? pre dependee_artifact) @@ -122,9 +119,7 @@ had_depender_after! (dictionary.key? post depender)]] - (wrap (and logging! - - had_dependee_before! + (wrap (and had_dependee_before! lacked_depender_before! had_dependee_after! diff --git a/stdlib/source/test/aedifex/command/install.lux b/stdlib/source/test/aedifex/command/install.lux index 33ee7192d..8096fc2b2 100644 --- a/stdlib/source/test/aedifex/command/install.lux +++ b/stdlib/source/test/aedifex/command/install.lux @@ -92,7 +92,7 @@ library_path (format artifact_path ///artifact/extension.lux_library) pom_path (format artifact_path ///artifact/extension.pom)] - #let [succeeded! (text\= //clean.success logging)] + #let [succeeded! (text\= /.success logging)] library_exists! (\ promise.monad map exception.return (file.file_exists? promise.monad fs library_path)) @@ -102,7 +102,7 @@ (wrap (and succeeded! library_exists! pom_exists!)))] - (_.cover' [/.do!] + (_.cover' [/.do! /.success] (try.default false verdict)))) (wrap (do {! promise.monad} [#let [fs (file.mock (\ file.default separator)) diff --git a/stdlib/source/test/aedifex/command/pom.lux b/stdlib/source/test/aedifex/command/pom.lux index c368d5f84..f7f182225 100644 --- a/stdlib/source/test/aedifex/command/pom.lux +++ b/stdlib/source/test/aedifex/command/pom.lux @@ -54,7 +54,7 @@ actual (!.use (\ file content) []) logging! (\ ///action.monad map - (text\= //clean.success) + (text\= /.success) (!.use (\ console read_line) [])) #let [expected_path! @@ -65,7 +65,7 @@ (wrap (and logging! expected_path! expected_content!)))] - (_.cover' [/.do!] + (_.cover' [/.do! /.success] (try.default false verdict))) (#try.Failure error) diff --git a/stdlib/source/test/aedifex/command/test.lux b/stdlib/source/test/aedifex/command/test.lux index 6b7ba9324..291b31863 100644 --- a/stdlib/source/test/aedifex/command/test.lux +++ b/stdlib/source/test/aedifex/command/test.lux @@ -51,7 +51,7 @@ #let [empty_profile (: Profile (\ ///.monoid identity)) with_target (: (-> Profile Profile) - (set@ #///.target (#.Some target))) + (set@ #///.target target)) with_test (: (-> Profile Profile) (set@ #///.test (#.Some test))) diff --git a/stdlib/source/test/aedifex/package.lux b/stdlib/source/test/aedifex/package.lux index 960a75f21..132c51b38 100644 --- a/stdlib/source/test/aedifex/package.lux +++ b/stdlib/source/test/aedifex/package.lux @@ -2,13 +2,21 @@ [lux #* ["_" test (#+ Test)] [abstract - [monad (#+ do)]] + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence]]}] [control ["." try] [concurrency [promise (#+ Promise)]]] [data - ["." text] + ["." product] + ["." text + [encoding + ["." utf8]]] + [format + ["." xml (#+ XML)]] [collection ["." set (#+ Set)]]] [math @@ -27,9 +35,11 @@ ["." / ["/#" // #_ ["#" profile] - ["#." dependency (#+ Dependency)] ["#." pom] - ["#." hash]]]}) + [dependency + ["#." status]] + [repository + ["#." origin]]]]}) (def: #export random (Random [//.Profile /.Package]) @@ -51,15 +61,37 @@ (do {! random.monad} [[profile package] ..random] ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence (\ ! map product.right ..random))) + + (_.cover [/.local?] + (/.local? (set@ #/.origin (#//origin.Local "~/yolo") package))) + (_.cover [/.remote?] + (/.remote? (set@ #/.origin (#//origin.Remote "https://example.com") package))) (_.cover [/.local] - false - ## (and (\ //hash.equivalence = - ## (//hash.sha-1 (get@ #/.library package)) - ## (get@ #/.sha-1 package)) - ## (\ //hash.equivalence = - ## (//hash.md5 (get@ #/.library package)) - ## (get@ #/.md5 package))) - ) + (let [expected_pom (|> package (get@ #/.pom) product.left) + expected_library (|> package (get@ #/.library) product.left) + + local (/.local expected_pom expected_library) + + [actual_pom binary_pom pom_status] (get@ #/.pom local) + [actual_library library_status] (get@ #/.library local)] + (and (case (get@ #/.origin local) + (#//origin.Local "") true + _ false) + (and (is? expected_library actual_library) + (case library_status + #//status.Unverified true + _ false)) + (and (is? expected_pom actual_pom) + (|> (do try.monad + [xml_pom (\ utf8.codec decode binary_pom) + decoded_pom (\ xml.codec decode xml_pom)] + (wrap (\ xml.equivalence = actual_pom decoded_pom))) + (try.default false)) + (case pom_status + #//status.Unverified true + _ false))))) (_.cover [/.dependencies] (let [expected (get@ #//.dependencies profile)] (case (/.dependencies package) @@ -68,4 +100,12 @@ (#try.Failure error) false))) + (_.cover [/.repositories] + (let [expected (get@ #//.repositories profile)] + (case (/.repositories package) + (#try.Success actual) + (\ set.equivalence = expected actual) + + (#try.Failure error) + false))) )))) diff --git a/stdlib/source/test/aedifex/profile.lux b/stdlib/source/test/aedifex/profile.lux index ea03a1e92..3410255f5 100644 --- a/stdlib/source/test/aedifex/profile.lux +++ b/stdlib/source/test/aedifex/profile.lux @@ -125,7 +125,7 @@ (..set_of text.hash ..repository) (..set_of //dependency.hash @dependency.random) (..set_of text.hash ..source) - (random.maybe ..target) + ..target (random.maybe (random.ascii/alpha 1)) (random.maybe (random.ascii/alpha 1)) (..dictionary_of text.hash (random.ascii/alpha 1) ..repository) diff --git a/stdlib/source/test/lux/type/check.lux b/stdlib/source/test/lux/type/check.lux index 45e648b9c..e6e0f4b16 100644 --- a/stdlib/source/test/lux/type/check.lux +++ b/stdlib/source/test/lux/type/check.lux @@ -1,20 +1,29 @@ (.module: [lux (#- type) - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract - ["." monad (#+ do)]] + ["." monad (#+ do)] + {[0 #spec] + [/ + ["$." functor (#+ Injection Comparison)] + ["$." apply] + ["$." monad]]}] [control - [pipe (#+ case>)]] + [pipe (#+ case>)] + ["." function] + ["." try] + ["." exception (#+ exception:)]] [data + ["." bit ("#\." equivalence)] ["." product] ["." maybe] - ["." text ("#\." equivalence)] + ["." text ("#\." equivalence) + ["%" format (#+ format)]] [collection - ["." list ("#\." functor)] + ["." list ("#\." functor monoid)] ["." set]]] [math - ["." random (#+ Random)] + ["." random (#+ Random) ("#\." monad)] [number ["n" nat]]] ["." type ("#\." equivalence)]] @@ -34,27 +43,26 @@ (-> Nat (Random Type)) (random.rec (function (_ recur) - (let [(^open "R\.") random.monad - pairG (random.and recur recur) - quantifiedG (random.and (R\wrap (list)) (type' (inc num_vars))) - random_pair (random.either (random.either (R\map (|>> #.Sum) pairG) - (R\map (|>> #.Product) pairG)) - (random.either (R\map (|>> #.Function) pairG) - (R\map (|>> #.Apply) pairG))) - random_id (let [random_id (random.either (R\map (|>> #.Var) random.nat) - (R\map (|>> #.Ex) random.nat))] + (let [pairG (random.and recur recur) + quantifiedG (random.and (random\wrap (list)) (type' (inc num_vars))) + random_pair (random.either (random.either (random\map (|>> #.Sum) pairG) + (random\map (|>> #.Product) pairG)) + (random.either (random\map (|>> #.Function) pairG) + (random\map (|>> #.Apply) pairG))) + random_id (let [random_id (random.either (random\map (|>> #.Var) random.nat) + (random\map (|>> #.Ex) random.nat))] (case num_vars 0 random_id - _ (random.either (R\map (|>> (n.% num_vars) (n.* 2) inc #.Parameter) random.nat) + _ (random.either (random\map (|>> (n.% num_vars) (n.* 2) inc #.Parameter) random.nat) random_id))) - random_quantified (random.either (R\map (|>> #.UnivQ) quantifiedG) - (R\map (|>> #.ExQ) quantifiedG))] + random_quantified (random.either (random\map (|>> #.UnivQ) quantifiedG) + (random\map (|>> #.ExQ) quantifiedG))] ($_ random.either - (R\map (|>> #.Primitive) (random.and ..short (R\wrap (list)))) + (random\map (|>> #.Primitive) (random.and ..short (random\wrap (list)))) random_pair random_id random_quantified - (R\map (|>> #.Named) (random.and ..name (type' 0))) + (random\map (|>> #.Named) (random.and ..name (type' 0))) ))))) (def: type @@ -81,178 +89,633 @@ _ #0)) -(def: (type_checks? input) - (-> (/.Check []) Bit) - (case (/.run /.fresh_context input) - (#.Right []) - #1 +(def: injection + (Injection (All [a] (/.Check a))) + (\ /.monad wrap)) - (#.Left error) - #0)) +(def: comparison + (Comparison (All [a] (/.Check a))) + (function (_ == left right) + (case [(/.run /.fresh_context left) (/.run /.fresh_context right)] + [(#try.Success left) (#try.Success right)] + (== left right) -(def: (build_ring num_connections) - (-> Nat (/.Check [[Nat Type] (List [Nat Type]) [Nat Type]])) - (do {! /.monad} - [[head_id head_type] /.var - ids+types (monad.seq ! (list.repeat num_connections /.var)) - [tail_id tail_type] (monad.fold ! (function (_ [tail_id tail_type] [_head_id _head_type]) - (do ! - [_ (/.check head_type tail_type)] - (wrap [tail_id tail_type]))) - [head_id head_type] - ids+types)] - (wrap [[head_id head_type] ids+types [tail_id tail_type]]))) + _ + false))) -(def: #export test +(def: polymorphism + Test + ($_ _.and + (_.for [/.functor] + ($functor.spec ..injection ..comparison /.functor)) + (_.for [/.apply] + ($apply.spec ..injection ..comparison /.apply)) + (_.for [/.monad] + ($monad.spec ..injection ..comparison /.monad)) + )) + +(exception: yolo) + +(def: error_handling Test - (<| (_.context (%.name (name_of /._))) + ($_ _.and + (do random.monad + [expected (random.ascii/upper 10)] + (_.cover [/.fail] + (case (/.run /.fresh_context + (: (/.Check Any) + (/.fail expected))) + (#try.Success _) false + (#try.Failure actual) (is? expected actual)))) + (do random.monad + [expected (random.ascii/upper 10)] + (_.cover [/.assert] + (and (case (/.run /.fresh_context + (: (/.Check Any) + (/.assert expected true))) + (#try.Success _) true + (#try.Failure actual) false) + (case (/.run /.fresh_context (/.assert expected false)) + (#try.Success _) false + (#try.Failure actual) (is? expected actual))))) + (_.cover [/.throw] + (case (/.run /.fresh_context + (: (/.Check Any) + (/.throw ..yolo []))) + (#try.Success _) false + (#try.Failure error) (exception.match? ..yolo error))) + )) + +(def: var + Test + (<| (_.for [/.Var]) ($_ _.and + (_.cover [/.var] + (case (/.run /.fresh_context + (do /.monad + [[var_id var_type] /.var] + (wrap (type\= var_type (#.Var var_id))))) + (#try.Success verdict) verdict + (#try.Failure error) false)) + (do random.monad + [nominal (random.ascii/upper 10)] + (_.cover [/.bind] + (case (/.run /.fresh_context + (do /.monad + [[var_id var_type] /.var + _ (/.bind (#.Primitive nominal (list)) + var_id)] + (wrap true))) + (#try.Success _) true + (#try.Failure error) false))) (do random.monad - [sample (random.filter ..valid_type? ..type)] - ($_ _.and - (_.test "Any is the super-type of everything." - (/.checks? Any sample)) - (_.test "Nothing is the sub-type of everything." - (/.checks? sample Nothing)) - )) - ($_ _.and - (_.test "Any and Nothing match themselves." - (and (/.checks? Nothing Nothing) - (/.checks? Any Any))) - (_.test "Existential types only match with themselves." - (and (type_checks? (do /.monad - [[_ exT] /.existential] - (/.check exT exT))) - (not (type_checks? (do /.monad - [[_ exTL] /.existential - [_ exTR] /.existential] - (/.check exTL exTR)))))) - (_.test "Names do not affect type-checking." - (and (type_checks? (do /.monad - [[_ exT] /.existential] - (/.check (#.Named ["module" "name"] exT) - exT))) - (type_checks? (do /.monad - [[_ exT] /.existential] - (/.check exT - (#.Named ["module" "name"] exT)))) - (type_checks? (do /.monad - [[_ exT] /.existential] - (/.check (#.Named ["module" "name"] exT) - (#.Named ["module" "name"] exT)))))) - (_.test "Functions are covariant on inputs and contravariant on outputs." - (and (/.checks? (#.Function Nothing Any) - (#.Function Any Nothing)) - (not (/.checks? (#.Function Any Nothing) - (#.Function Nothing Any))))) - ) + [nominal (random.ascii/upper 10)] + (_.cover [/.bound?] + (and (|> (do /.monad + [[var_id var_type] /.var + pre (/.bound? var_id) + _ (/.bind (#.Primitive nominal (list)) + var_id) + post (/.bound? var_id)] + (wrap (and (not pre) + post))) + (/.run /.fresh_context) + (try.default false)) + (|> (do /.monad + [[var_id var/0] /.var + pre (/.bound? var_id) + [_ var/1] /.var + _ (/.check var/0 var/1) + post (/.bound? var_id)] + (wrap (and (not pre) + (not post)))) + (/.run /.fresh_context) + (try.default false))))) (do random.monad - [meta ..type - data ..type] - (_.test "Can type-check type application." - (and (/.checks? (|> Ann (#.Apply meta) (#.Apply data)) - (type.tuple (list meta data))) - (/.checks? (type.tuple (list meta data)) - (|> Ann (#.Apply meta) (#.Apply data)))))) + [nominal (random.ascii/upper 10)] + (_.cover [/.cannot_rebind_var] + (case (/.run /.fresh_context + (do /.monad + [[var_id var_type] /.var + _ (/.bind (#.Primitive nominal (list)) + var_id)] + (/.bind (#.Primitive nominal (list)) + var_id))) + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.cannot_rebind_var error)))) + (do random.monad + [nominal (random.ascii/upper 10) + var_id random.nat] + (_.cover [/.unknown_type_var] + (case (/.run /.fresh_context + (/.bind (#.Primitive nominal (list)) + var_id)) + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.unknown_type_var error)))) + (do random.monad + [nominal (random.ascii/upper 10) + #let [expected (#.Primitive nominal (list))]] + (_.cover [/.read] + (and (|> (do /.monad + [[var_id var_type] /.var] + (/.read var_id)) + (/.run /.fresh_context) + (case> (#try.Success #.None) true + _ false)) + (|> (do /.monad + [[var_id var/0] /.var + [_ var/1] /.var + _ (/.check var/0 var/1)] + (/.read var_id)) + (/.run /.fresh_context) + (case> (#try.Success #.None) true + _ false)) + (|> (do /.monad + [[var_id var_type] /.var + _ (/.bind expected var_id)] + (/.read var_id)) + (/.run /.fresh_context) + (case> (#try.Success (#.Some actual)) + (is? expected actual) + + _ + false))))) + (do random.monad + [nominal (random.ascii/upper 10) + #let [expected (#.Primitive nominal (list))]] + (_.cover [/.read!] + (case (/.run /.fresh_context + (do /.monad + [[var_id var_type] /.var + _ (/.bind expected var_id)] + (/.read! var_id))) + (#try.Success actual) + (is? expected actual) + + _ + false))) + (do random.monad + [nominal (random.ascii/upper 10) + #let [expected (#.Primitive nominal (list))]] + (_.cover [/.unbound_type_var] + (case (/.run /.fresh_context + (do /.monad + [[var_id var_type] /.var] + (/.read! var_id))) + (#try.Failure error) + (exception.match? /.unbound_type_var error) + + _ + false))) + ))) + +(def: context + Test + ($_ _.and + (_.cover [/.fresh_context] + (and (n.= 0 (get@ #.var_counter /.fresh_context)) + (n.= 0 (get@ #.ex_counter /.fresh_context)) + (list.empty? (get@ #.var_bindings /.fresh_context)))) + (_.cover [/.context] + (and (case (/.run /.fresh_context /.context) + (#try.Success actual) + (is? /.fresh_context actual) + + (#try.Failure error) + false) + (case (/.run /.fresh_context + (do /.monad + [_ /.var] + /.context)) + (#try.Success actual) + (and (n.= 1 (get@ #.var_counter actual)) + (n.= 0 (get@ #.ex_counter actual)) + (n.= 1 (list.size (get@ #.var_bindings actual)))) + + (#try.Failure error) + false))) + (_.cover [/.existential] + (case (/.run /.fresh_context + (do /.monad + [_ /.existential] + /.context)) + (#try.Success actual) + (and (n.= 0 (get@ #.var_counter actual)) + (n.= 1 (get@ #.ex_counter actual)) + (n.= 0 (list.size (get@ #.var_bindings actual)))) + + (#try.Failure error) + false)) + )) + +(def: succeeds? + (All [a] (-> (/.Check a) Bit)) + (|>> (/.run /.fresh_context) + (case> (#try.Success _) + true + + (#try.Failure error) + false))) + +(def: fails? + (All [a] (-> (/.Check a) Bit)) + (|>> ..succeeds? + not)) + +(def: nominal + (Random Type) + (do random.monad + [name (random.ascii/upper 10)] + (wrap (#.Primitive name (list))))) + +(def: (non_twins = random) + (All [a] (-> (-> a a Bit) (Random a) (Random [a a]))) + (do random.monad + [left random + right (random.filter (|>> (= left) not) random)] + (wrap [left right]))) + +(type: Super + (Ex [sub] [Text sub])) + +(type: Sub + (Super Bit)) + +(def: (handles_nominal_types! name/0 name/1 parameter/0 parameter/1) + (-> Text Text Type Type Bit) + (let [names_matter! + (and (..succeeds? (/.check (#.Primitive name/0 (list)) + (#.Primitive name/0 (list)))) + (..fails? (/.check (#.Primitive name/0 (list)) + (#.Primitive name/1 (list))))) + + parameters_matter! + (and (..succeeds? (/.check (#.Primitive name/0 (list parameter/0)) + (#.Primitive name/0 (list parameter/0)))) + (..fails? (/.check (#.Primitive name/0 (list parameter/0)) + (#.Primitive name/0 (list parameter/1))))) + + covariant_parameters! + (and (..succeeds? (/.check (#.Primitive name/0 (list Super)) + (#.Primitive name/0 (list Sub)))) + (..fails? (/.check (#.Primitive name/0 (list Sub)) + (#.Primitive name/0 (list Super)))))] + (and names_matter! + parameters_matter! + covariant_parameters!))) + +(template [<assertion> <combinator>] + [(def: (<assertion> name/0 name/1) + (-> Text Text Bit) + (let [pair/0 (<combinator> (#.Primitive name/0 (list)) (#.Primitive name/0 (list))) + pair/1 (<combinator> (#.Primitive name/1 (list)) (#.Primitive name/1 (list))) + + invariant! + (and (..succeeds? (/.check pair/0 pair/0)) + (..fails? (/.check pair/0 pair/1))) + + super_pair (<combinator> Super Super) + sub_pair (<combinator> Sub Sub) + + covariant! + (and (..succeeds? (/.check super_pair sub_pair)) + (..fails? (/.check sub_pair super_pair)))] + (and invariant! + covariant!)))] + + [handles_products! #.Product] + [handles_sums! #.Sum] + ) + +(def: (handles_function_variance! nominal) + (-> Type Bit) + (let [functions_have_contravariant_inputs! + (..succeeds? (/.check (#.Function Sub nominal) (#.Function Super nominal))) + + functions_have_covariant_outputs! + (..succeeds? (/.check (#.Function nominal Super) (#.Function nominal Sub)))] + (and functions_have_contravariant_inputs! + functions_have_covariant_outputs!))) + +(def: (verdict check) + (All [_] (-> (/.Check _) (/.Check Bit))) + (function (_ context) + (#try.Success [context (case (check context) + (#try.Success _) + true + + (#try.Failure _) + false)]))) + +(def: (build_ring tail_size) + (-> Nat (/.Check [Type (List Type) Type])) + (do {! /.monad} + [[id/head var/head] /.var + var/tail+ (monad.map ! (function (_ _) + (do ! + [[id/T var/tail] /.var] + (wrap var/tail))) + (list.repeat tail_size /.var)) + var/last (monad.fold ! (function (_ var/next var/prev) + (do ! + [_ (/.check var/prev var/next)] + (wrap var/next))) + var/head + var/tail+) + _ (/.check var/last var/head)] + (wrap [var/head var/tail+ var/last]))) + +(def: (handles_var_rings! tail_size nominal/0 nominal/1) + (-> Nat Type Type Bit) + (let [can_create_rings_of_variables! + (succeeds? (..build_ring tail_size)) + + can_bind_rings_of_variables! + (succeeds? (do {! /.monad} + [[var/head var/tail+ var/last] (..build_ring tail_size) + _ (/.check var/head nominal/0) + failures (monad.map ! (|>> (/.check nominal/1) ..verdict) (list& var/head var/tail+)) + successes (monad.map ! (|>> (/.check nominal/0) ..verdict) (list& var/head var/tail+))] + (/.assert "" (and (list.every? (bit\= false) failures) + (list.every? (bit\= true) successes))))) + + can_merge_multiple_rings_of_variables! + (succeeds? (do {! /.monad} + [[var/head/0 var/tail+/0 var/last/0] (..build_ring tail_size) + [var/head/1 var/tail+/1 var/last/1] (..build_ring tail_size) + _ (/.check var/head/0 var/head/1) + _ (/.check var/head/0 nominal/0) + #let [all_variables (list\compose (list& var/head/0 var/tail+/0) + (list& var/head/1 var/tail+/1))] + failures (monad.map ! (|>> (/.check nominal/1) ..verdict) all_variables) + successes (monad.map ! (|>> (/.check nominal/0) ..verdict) all_variables)] + (/.assert "" (and (list.every? (bit\= false) failures) + (list.every? (bit\= true) successes)))))] + (and can_create_rings_of_variables! + can_bind_rings_of_variables! + can_merge_multiple_rings_of_variables!))) + +(def: (handles_vars! nominal) + (-> Type Bit) + (let [vars_check_against_themselves! + (succeeds? (do /.monad + [[id var] /.var] + (/.check var var))) + + can_bind_vars_by_checking_against_them! + (and (succeeds? (do /.monad + [[id var] /.var] + (/.check var nominal))) + (succeeds? (do /.monad + [[id var] /.var] + (/.check nominal var)))) + + cannot_rebind! + (fails? (do /.monad + [[id var] /.var + _ (/.check var nominal)] + (/.check var ..Sub))) + + bound_vars_check_against_their_bound_types! + (and (succeeds? (do /.monad + [[id var] /.var + _ (/.check var nominal)] + (/.check nominal var))) + (succeeds? (do /.monad + [[id var] /.var + _ (/.check var ..Super)] + (/.check var ..Sub))) + (succeeds? (do /.monad + [[id var] /.var + _ (/.check var ..Sub)] + (/.check ..Super var))) + + (fails? (do /.monad + [[id var] /.var + _ (/.check var ..Super)] + (/.check ..Sub var))) + (fails? (do /.monad + [[id var] /.var + _ (/.check var ..Sub)] + (/.check var ..Super))))] + (and vars_check_against_themselves! + can_bind_vars_by_checking_against_them! + cannot_rebind! + bound_vars_check_against_their_bound_types!))) + +(def: handles_existentials! + Bit + (let [existentials_always_match_themselves! + (..succeeds? (do /.monad + [[_ single] /.existential] + (/.check single single))) + + existentials_never_match_each_other! + (..fails? (do /.monad + [[_ left] /.existential + [_ right] /.existential] + (/.check left right)))] + (and existentials_always_match_themselves! + existentials_never_match_each_other!))) + +(def: (handles_quantification! nominal) + (-> Type Bit) + (let [universals_satisfy_themselves! + (..succeeds? (/.check (.type (All [a] (Maybe a))) + (.type (All [a] (Maybe a))))) + + existentials_satisfy_themselves! + (..succeeds? (/.check (.type (Ex [a] (Maybe a))) + (.type (Ex [a] (Maybe a))))) + + universals_satisfy_particulars! + (..succeeds? (/.check (.type (Maybe nominal)) + (.type (All [a] (Maybe a))))) + + particulars_do_not_satisfy_universals! + (..fails? (/.check (.type (All [a] (Maybe a))) + (.type (Maybe nominal)))) + + particulars_satisfy_existentials! + (..succeeds? (/.check (.type (Ex [a] (Maybe a))) + (.type (Maybe nominal)))) + + existentials_do_not_satisfy_particulars! + (..fails? (/.check (.type (Maybe nominal)) + (.type (Ex [a] (Maybe a)))))] + (and universals_satisfy_themselves! + existentials_satisfy_themselves! + + universals_satisfy_particulars! + particulars_do_not_satisfy_universals! + + particulars_satisfy_existentials! + existentials_do_not_satisfy_particulars! + ))) + +(def: (handles_ultimates! nominal) + (-> Type Bit) + (let [any_is_the_ultimate_super_type! + (and (..succeeds? (/.check Any nominal)) + (..fails? (/.check nominal Any))) + + nothing_is_the_ultimate_sub_type! + (and (..succeeds? (/.check nominal Nothing)) + (..fails? (/.check Nothing nominal))) + + ultimates_check_themselves! + (and (..succeeds? (/.check Any Any)) + (..succeeds? (/.check Nothing Nothing)))] + (and any_is_the_ultimate_super_type! + nothing_is_the_ultimate_sub_type! + ultimates_check_themselves!))) + +(def: (names_do_not_affect_types! left_name right_name nominal) + (-> Name Name Type Bit) + (and (..succeeds? (/.check (#.Named left_name Any) nominal)) + (..succeeds? (/.check Any (#.Named right_name nominal))) + (..succeeds? (/.check (#.Named left_name Any) (#.Named right_name nominal))))) + +## TODO: Test all the crazy corner cases from /.check_apply +(def: (handles_application! nominal/0 nominal/1) + (-> Type Type Bit) + (let [types_flow_through! + (and (..succeeds? (/.check (.type ((All [a] a) nominal/0)) + nominal/0)) + (..succeeds? (/.check nominal/0 + (.type ((All [a] a) nominal/0)))) + + (..succeeds? (/.check (.type ((Ex [a] a) nominal/0)) + nominal/0)) + (..succeeds? (/.check nominal/0 + (.type ((Ex [a] a) nominal/0))))) + + multiple_parameters! + (and (..succeeds? (/.check (.type ((All [a b] [a b]) nominal/0 nominal/1)) + (.type [nominal/0 nominal/1]))) + (..succeeds? (/.check (.type [nominal/0 nominal/1]) + (.type ((All [a b] [a b]) nominal/0 nominal/1)))) + + (..succeeds? (/.check (.type ((Ex [a b] [a b]) nominal/0 nominal/1)) + (.type [nominal/0 nominal/1]))) + (..succeeds? (/.check (.type [nominal/0 nominal/1]) + (.type ((Ex [a b] [a b]) nominal/0 nominal/1)))))] + (and types_flow_through! + multiple_parameters!))) + +(def: check + Test + (do {! random.monad} + [nominal ..nominal + [name/0 name/1] (..non_twins text\= (random.ascii/upper 10)) + [parameter/0 parameter/1] (..non_twins type\= ..nominal) + left_name ..name + right_name ..name + ring_tail_size (\ ! map (n.% 10) random.nat)] + (_.cover [/.check] + (and (..handles_nominal_types! name/0 name/1 parameter/0 parameter/1) + (..handles_products! name/0 name/1) + (..handles_sums! name/0 name/1) + (..handles_function_variance! nominal) + (..handles_vars! nominal) + (..handles_var_rings! ring_tail_size parameter/0 parameter/1) + ..handles_existentials! + (..handles_quantification! nominal) + (..handles_ultimates! nominal) + (..handles_application! parameter/0 parameter/1) + (..names_do_not_affect_types! left_name right_name nominal) + )))) + +(def: dirty_type + (Random (-> Type Type)) + (random.rec + (function (_ dirty_type) + (`` ($_ random.either + (random\map (function (_ id) + (function.constant (#.Ex id))) + random.nat) + (do random.monad + [module (random.ascii/upper 10) + short (random.ascii/upper 10) + anonymousT dirty_type] + (wrap (function (_ holeT) + (#.Named [module short] (anonymousT holeT))))) + (~~ (template [<tag>] + [(do random.monad + [leftT dirty_type + rightT dirty_type] + (wrap (function (_ holeT) + (<tag> (leftT holeT) (rightT holeT)))))] + + [#.Sum] + [#.Product] + [#.Function] + [#.Apply] + )) + (do {! random.monad} + [name (random.ascii/upper 10) + parameterT dirty_type] + (wrap (function (_ holeT) + (#.Primitive name (list (parameterT holeT)))))) + (~~ (template [<tag>] + [(do {! random.monad} + [funcT dirty_type + argT dirty_type + body random.nat] + (wrap (function (_ holeT) + (<tag> (list (funcT holeT) (argT holeT)) + (#.Parameter body)))))] + + [#.UnivQ] + [#.ExQ] + )) + ))))) + +(def: clean + Test + (do random.monad + [type_shape ..dirty_type] + (_.cover [/.clean] + (and (|> (do /.monad + [[var_id varT] /.var + cleanedT (/.clean (type_shape varT))] + (wrap (type\= (type_shape varT) + cleanedT))) + (/.run /.fresh_context) + (try.default false)) + (|> (do /.monad + [[var_id varT] /.var + [_ replacementT] /.existential + _ (/.check varT replacementT) + cleanedT (/.clean (type_shape varT))] + (wrap (type\= (type_shape replacementT) + cleanedT))) + (/.run /.fresh_context) + (try.default false)) + )))) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Check]) + ($_ _.and + ..polymorphism (do random.monad - [#let [gen_short (random.ascii 10)] - nameL gen_short - nameR (|> gen_short (random.filter (|>> (text\= nameL) not))) - paramL ..type - paramR (random.filter (|>> (/.checks? paramL) not) ..type)] - ($_ _.and - (_.test "Primitive types match when they have the same name and the same parameters." - (/.checks? (#.Primitive nameL (list paramL)) - (#.Primitive nameL (list paramL)))) - (_.test "Names matter to primitive types." - (not (/.checks? (#.Primitive nameL (list paramL)) - (#.Primitive nameR (list paramL))))) - (_.test "Parameters matter to primitive types." - (not (/.checks? (#.Primitive nameL (list paramL)) - (#.Primitive nameL (list paramR))))) - )) - ($_ _.and - (_.test "Type-vars check against themselves." - (type_checks? (do /.monad - [[id var] /.var] - (/.check var var)))) - (_.test "Can bind unbound type-vars by type-checking against them." - (and (type_checks? (do /.monad - [[id var] /.var] - (/.check var .Any))) - (type_checks? (do /.monad - [[id var] /.var] - (/.check .Any var))))) - (_.test "Cannot rebind already bound type-vars." - (not (type_checks? (do /.monad - [[id var] /.var - _ (/.check var .Bit)] - (/.check var .Nat))))) - (_.test "If the type bound to a var is a super-type to another, then the var is also a super-type." - (type_checks? (do /.monad - [[id var] /.var - _ (/.check var Any)] - (/.check var .Bit)))) - (_.test "If the type bound to a var is a sub-type of another, then the var is also a sub-type." - (type_checks? (do /.monad - [[id var] /.var - _ (/.check var Nothing)] - (/.check .Bit var)))) - ) - (do {! random.monad} - [num_connections (|> random.nat (\ ! map (n.% 100))) - boundT (|> ..type (random.filter (|>> (case> (#.Var _) #0 _ #1)))) - pick_pcg (random.and random.nat random.nat)] - ($_ _.and - (_.test "Can create rings of variables." - (type_checks? (do /.monad - [[[head_id head_type] ids+types [tail_id tail_type]] (build_ring num_connections) - #let [ids (list\map product.left ids+types)] - headR (/.ring head_id) - tailR (/.ring tail_id)] - (/.assert "" - (let [same_rings? (\ set.equivalence = headR tailR) - expected_size? (n.= (inc num_connections) (set.size headR)) - same_vars? (|> (set.to_list headR) - (list.sort n.<) - (\ (list.equivalence n.equivalence) = (list.sort n.< (#.Cons head_id ids))))] - (and same_rings? - expected_size? - same_vars?)))))) - (_.test "When a var in a ring is bound, all the ring is bound." - (type_checks? (do {! /.monad} - [[[head_id headT] ids+types tailT] (build_ring num_connections) - #let [ids (list\map product.left ids+types)] - _ (/.check headT boundT) - head_bound (/.read head_id) - tail_bound (monad.map ! /.read ids) - headR (/.ring head_id) - tailR+ (monad.map ! /.ring ids)] - (let [rings_were_erased? (and (set.empty? headR) - (list.every? set.empty? tailR+)) - same_types? (list.every? (type\= boundT) (list& (maybe.default headT head_bound) - (list\map (function (_ [tail_id ?tailT]) - (maybe.default (#.Var tail_id) ?tailT)) - (list.zip/2 ids tail_bound))))] - (/.assert "" - (and rings_were_erased? - same_types?)))))) - (_.test "Can merge multiple rings of variables." - (type_checks? (do /.monad - [[[head_idL headTL] ids+typesL [tail_idL tailTL]] (build_ring num_connections) - [[head_idR headTR] ids+typesR [tail_idR tailTR]] (build_ring num_connections) - headRL_pre (/.ring head_idL) - headRR_pre (/.ring head_idR) - _ (/.check headTL headTR) - headRL_post (/.ring head_idL) - headRR_post (/.ring head_idR)] - (/.assert "" - (let [same_rings? (\ set.equivalence = headRL_post headRR_post) - expected_size? (n.= (n.* 2 (inc num_connections)) - (set.size headRL_post)) - union? (\ set.equivalence = headRL_post (set.union headRL_pre headRR_pre))] - (and same_rings? - expected_size? - union?)))))) - )) + [expected random.nat] + (_.cover [/.run] + (case (/.run /.fresh_context + (\ /.monad wrap expected)) + (#try.Success actual) (is? expected actual) + (#try.Failure error) false))) + ..error_handling + ..var + ..context + ..check + ..clean ))) |