diff options
Diffstat (limited to '')
34 files changed, 764 insertions, 601 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 2b9d0b27e..de071c35a 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -4593,7 +4593,7 @@ (return (list (` ((let [(^open ".") (~ struct)] (~ (identifier$ member))) (~+ args))))) _ - (fail "Wrong syntax for ::"))) + (fail "Wrong syntax for \"))) (macro: #export (set@ tokens) {#.doc (text$ ($_ "lux text concat" diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index 3683e9e57..bee2d2983 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -71,7 +71,7 @@ (def: xml_char^ (Parser Text) - (<>.either (<text>.none_of ($_ text\compose "<>&'" text.double_quote)) + (<>.either (<text>.none_of ($_ text\compose "<>&" text.double_quote)) xml_escape_char^)) (def: xml_identifier @@ -134,7 +134,7 @@ (Parser Text) (|> (<text>.not (<text>.this "--")) <text>.some - (<text>.enclosed ["<--" "-->"]) + (<text>.enclosed ["<!--" "-->"]) spaced^)) (def: xml_header^ @@ -154,8 +154,8 @@ (def: text^ (Parser XML) - (|> (<>.either cdata^ - (..spaced^ (<text>.many xml_char^))) + (|> (..spaced^ (<text>.many xml_char^)) + (<>.either cdata^) (<>\map (|>> #Text)))) (def: null^ @@ -166,28 +166,33 @@ (Parser XML) (|> (<>.rec (function (_ node^) - (<>.either text^ - (spaced^ - (do <>.monad - [_ (<text>.this "<") - tag (spaced^ tag^) - attrs (spaced^ attrs^) - #let [no_children^ (do <>.monad - [_ (<text>.this "/>")] - (wrap (#Node tag attrs (list)))) - with_children^ (do <>.monad - [_ (<text>.this ">") - children (<>.some node^) - _ (close_tag^ tag)] - (wrap (#Node tag attrs children)))]] - (<>.either no_children^ - with_children^)))))) - ## This is put outside of the call to "rec" because comments - ## cannot be located inside of XML nodes. - ## This way, the comments can only be before or after the main document. - (<>.before (<>.some comment^)) + (|> (spaced^ + (do <>.monad + [_ (<text>.this "<") + tag (spaced^ tag^) + attrs (spaced^ attrs^) + #let [no_children^ (do <>.monad + [_ (<text>.this "/>")] + (wrap (#Node tag attrs (list)))) + ## TODO: Find a way to make do without this hack. Without it, some POM files fail when parsing them in Aedifex. Something like this fails: <configuration> </configuration> + alternative_no_children^ (do <>.monad + [_ (<text>.this ">") + _ (<>.some <text>.space) + _ (..close_tag^ tag)] + (wrap (#Node tag attrs (list)))) + with_children^ (do <>.monad + [_ (<text>.this ">") + children (<>.some node^) + _ (..close_tag^ tag)] + (wrap (#Node tag attrs children)))]] + ($_ <>.either + no_children^ + alternative_no_children^ + with_children^))) + (<>.before (<>.some ..comment^)) + (<>.after (<>.some ..comment^)) + (<>.either text^)))) (<>.before (<>.some ..null^)) - (<>.after (<>.some comment^)) (<>.after (<>.maybe xml_header^)))) (def: read diff --git a/stdlib/source/lux/target/lua.lux b/stdlib/source/lux/target/lua.lux index be46169dd..c1bceb634 100644 --- a/stdlib/source/lux/target/lua.lux +++ b/stdlib/source/lux/target/lua.lux @@ -1,5 +1,8 @@ (.module: [lux (#- Location Code int if cond function or and not let) + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] [control [pipe (#+ case> cond> new>)]] [data @@ -27,6 +30,18 @@ (abstract: #export (Code brand) Text + (structure: #export equivalence + (All [brand] (Equivalence (Code brand))) + + (def: (= reference subject) + (\ text.equivalence = (:representation reference) (:representation subject)))) + + (structure: #export hash + (All [brand] (Hash (Code brand))) + + (def: &equivalence ..equivalence) + (def: hash (|>> :representation (\ text.hash hash)))) + (def: #export manual (-> Text Code) (|>> :abstraction)) @@ -225,6 +240,10 @@ (local vars) (set vars value))) + (def: #export (local/1 var value) + (-> Var Expression Statement) + (:abstraction (format "local " (:representation var) " = " (:representation value) ..statement_suffix))) + (def: #export (if test then! else!) (-> Expression Statement Statement Statement) (:abstraction (format "if " (:representation test) @@ -280,15 +299,20 @@ (text.enclose ["(" ")"]) :abstraction)) - (def: #export (function name args body!) - (-> Var (List Var) Statement Statement) - (:abstraction - (format "function " (:representation name) - (|> args - ..locations - (text.enclose ["(" ")"])) - (..nest (:representation body!)) - text.new_line "end" ..statement_suffix))) + (template [<name> <code>] + [(def: #export (<name> name args body!) + (-> Var (List Var) Statement Statement) + (:abstraction + (format <code> " " (:representation name) + (|> args + ..locations + (text.enclose ["(" ")"])) + (..nest (:representation body!)) + text.new_line "end" ..statement_suffix)))] + + [function "function"] + [local_function "local function"] + ) (def: #export break Statement diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux index 2f1917de9..7d7ce2fbf 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux @@ -39,13 +39,13 @@ (/.install "or" (binary (product.uncurry _.bit_or))) (/.install "xor" (binary (product.uncurry _.bit_xor))) (/.install "left-shift" (binary (product.uncurry _.bit_shl))) - (/.install "logical-right-shift" (binary (product.uncurry //runtime.i64//logic_right_shift))) + (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) (/.install "=" (binary (product.uncurry _.=))) (/.install "+" (binary (product.uncurry _.+))) (/.install "-" (binary (product.uncurry _.-))) (/.install "<" (binary (product.uncurry _.<))) (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry _./))) + (/.install "/" (binary (product.uncurry _.//))) (/.install "%" (binary (product.uncurry _.%))) (/.install "f64" (unary (_./ (_.float +1.0)))) (/.install "char" (unary (!unary "string.char"))) @@ -97,8 +97,8 @@ (def: (io//log! messageO) (Unary Expression) - (_.or (_.apply/* (list messageO) (_.var "print")) - //runtime.unit)) + (|> (_.apply/* (list messageO) (_.var "print")) + (_.or //runtime.unit))) (def: io_procs Bundle diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux index e6dad82e5..3c56c2dfa 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux @@ -3,7 +3,8 @@ [abstract ["." monad (#+ do)]] [data - ["." text] + ["." text + ["%" format (#+ format)]] [collection ["." list ("#\." functor fold)] ["." set]]] @@ -20,9 +21,10 @@ ["#/." case]] ["/#" // #_ ["#." synthesis (#+ Member Synthesis Path)] + ["#." generation] ["//#" /// #_ [reference - [variable (#+ Register)]] + ["#." variable (#+ Register)]] ["#." phase ("#\." monad)] [meta [archive (#+ Archive)]]]]]]]) @@ -31,6 +33,10 @@ (-> Register Var) (|>> (///reference.local //reference.system) :assume)) +(def: #export capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) :assume)) + (def: #export (let generate archive [valueS register bodyS]) (Generator [Synthesis Register Synthesis]) (do ///////phase.monad @@ -139,7 +145,7 @@ (///////phase\wrap ..pop!) (#/////synthesis.Bind register) - (///////phase\wrap (_.let (list (..register register)) ..peek)) + (///////phase\wrap (_.local/1 (..register register) ..peek)) (#/////synthesis.Bit_Fork when thenP elseP) (do {! ///////phase.monad} @@ -195,7 +201,7 @@ (do ///////phase.monad [then! (recur thenP)] (///////phase\wrap ($_ _.then - (_.let (list (..register register)) ..peek_and_pop) + (_.local/1 (..register register) ..peek_and_pop) then!))) (^template [<tag> <combinator>] @@ -216,15 +222,34 @@ pattern_matching!) (_.statement (|> (_.var "error") (_.apply/* (list (_.string ////synthesis/case.pattern_matching_error))))))))) +(def: #export dependencies + (-> Path (List Var)) + (|>> ////synthesis/case.storage + (get@ #////synthesis/case.dependencies) + set.to_list + (list\map (function (_ variable) + (.case variable + (#///////variable.Local register) + (..register register) + + (#///////variable.Foreign register) + (..capture register)))))) + (def: #export (case generate archive [valueS pathP]) (Generator [Synthesis Path]) (do ///////phase.monad [initG (generate archive valueS) - pattern_matching! (pattern_matching generate archive pathP)] - (wrap (|> ($_ _.then - (_.local (list @temp)) - (_.let (list @cursor) (_.array (list initG))) - (_.let (list @savepoint) (_.array (list))) - pattern_matching!) - (_.closure (list)) - (_.apply/* (list)))))) + [[case_module case_artifact] pattern_matching!] (/////generation.with_new_context archive + (pattern_matching generate archive pathP)) + #let [@case (_.var (///reference.artifact [case_module case_artifact])) + @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS) + pathP)) + directive (_.function @case @dependencies+ + ($_ _.then + (_.local (list @temp)) + (_.local/1 @cursor (_.array (list initG))) + (_.local/1 @savepoint (_.array (list))) + pattern_matching!))] + _ (/////generation.execute! directive) + _ (/////generation.save! (%.nat case_artifact) directive)] + (wrap (_.apply/* @dependencies+ @case)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux index 7c07c8c6d..c7fe7f51c 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux @@ -6,6 +6,8 @@ pipe] [data ["." product] + [text + ["%" format (#+ format)]] [collection ["." list ("#\." functor fold)]]] [target @@ -37,23 +39,24 @@ (-> Register Var) (|>> (///reference.foreign //reference.system) :assume)) -(def: (with_closure function_name inits function_definition) - (-> Text (List Expression) Statement (Operation Expression)) +(def: (with_closure function_name inits @function @args @body) + (-> Text (List Expression) Var (List Var) Statement (Operation Expression)) (case inits #.Nil (do ///////phase.monad - [_ (/////generation.execute! function_definition) + [#let [function_definition (_.function @function @args @body)] + _ (/////generation.execute! function_definition) _ (/////generation.save! function_name function_definition)] - (wrap (|> (_.var function_name) (_.apply/* inits)))) + (wrap (_.var function_name))) _ (do {! ///////phase.monad} - [@closure (\ ! map _.var (/////generation.gensym "closure")) - #let [directive (_.function @closure + [#let [@closure (_.var (format function_name "_closure")) + directive (_.function @closure (|> (list.enumeration inits) (list\map (|>> product.left ..capture))) ($_ _.then - function_definition + (_.local_function @function @args @body) (_.return (_.var function_name))))] _ (/////generation.execute! directive) _ (/////generation.save! (_.code @closure) directive)] @@ -77,35 +80,35 @@ arityO (|> arity .int _.int) @num_args (_.var "num_args") @self (_.var function_name) - initialize_self! (_.let (list (//case.register 0)) @self) + initialize_self! (_.local/1 (//case.register 0) @self) initialize! (list\fold (.function (_ post pre!) ($_ _.then pre! - (_.let (list (..input post)) (_.nth (|> post inc .int _.int) @curried)))) + (_.local/1 (..input post) (_.nth (|> post inc .int _.int) @curried)))) initialize_self! (list.indices arity)) - pack (|>> (list) _.apply/* (|> (_.var "table.pack"))) + pack (|>> (list) _.array) unpack (|>> (list) _.apply/* (|> (_.var "table.unpack"))) @var_args (_.var "...")]] (with_closure function_name closureO+ - (_.function @self (list @var_args) - ($_ _.then - (_.let (list @curried) (pack @var_args)) - (_.let (list @num_args) (_.the "n" @curried)) - (_.cond (list [(|> @num_args (_.= (_.int +0))) - (_.return @self)] - [(|> @num_args (_.= arityO)) - ($_ _.then - initialize! - (_.return bodyO))] - [(|> @num_args (_.> arityO)) - (let [arity_inputs (//runtime.array//sub (_.int +0) arityO @curried) - extra_inputs (//runtime.array//sub arityO @num_args @curried)] - (_.return (|> @self - (_.apply/* (list (unpack arity_inputs))) - (_.apply/* (list (unpack extra_inputs))))))]) - ## (|> @num_args (_.< arityO)) - (_.return (_.closure (list @var_args) - (_.return (|> @self (_.apply/* (list (unpack (//runtime.array//concat @curried (pack @var_args)))))))))) - ))) + @self (list @var_args) + ($_ _.then + (_.local/1 @curried (pack @var_args)) + (_.local/1 @num_args (_.length @curried)) + (_.cond (list [(|> @num_args (_.= (_.int +0))) + (_.return @self)] + [(|> @num_args (_.= arityO)) + ($_ _.then + initialize! + (_.return bodyO))] + [(|> @num_args (_.> arityO)) + (let [arity_inputs (//runtime.array//sub (_.int +0) arityO @curried) + extra_inputs (//runtime.array//sub arityO @num_args @curried)] + (_.return (|> @self + (_.apply/* (list (unpack arity_inputs))) + (_.apply/* (list (unpack extra_inputs))))))]) + ## (|> @num_args (_.< arityO)) + (_.return (_.closure (list @var_args) + (_.return (|> @self (_.apply/* (list (unpack (//runtime.array//concat @curried (pack @var_args)))))))))) + )) )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux index 817ba118a..b1b8a47cb 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux @@ -7,22 +7,25 @@ [text ["%" format (#+ format)]] [collection - ["." list ("#\." functor)]]] + ["." list ("#\." functor)] + ["." set]]] [math [number ["n" nat]]] [target - ["_" lua (#+ Expression Var)]]] + ["_" lua (#+ Var Expression Statement)]]] ["." // #_ [runtime (#+ Operation Phase Phase! Generator Generator!)] ["#." case] - ["///#" //// #_ - [synthesis (#+ Scope Synthesis)] - ["#." generation] + ["/#" // #_ + ["#." reference] ["//#" /// #_ - ["#." phase] - [reference - [variable (#+ Register)]]]]]) + ["."synthesis (#+ Scope Synthesis)] + ["#." generation] + ["//#" /// #_ + ["#." phase] + [reference + [variable (#+ Register)]]]]]]) (def: loop_name (-> Nat Var) @@ -30,18 +33,49 @@ (def: #export (scope generate archive [start initsS+ bodyS]) (Generator (Scope Synthesis)) - (do {! ///////phase.monad} - [@loop (\ ! map ..loop_name /////generation.next) - initsO+ (monad.map ! (generate archive) initsS+) - bodyO (/////generation.with_anchor @loop - (generate archive bodyS)) - #let [directive (_.function @loop (|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register))) - (_.return bodyO))] - _ (/////generation.execute! directive) - _ (/////generation.save! (_.code @loop) directive)] - (wrap (_.apply/* initsO+ @loop)))) + (case initsS+ + ## function/false/non-independent loop + #.Nil + (generate archive bodyS) + + ## true loop + _ + (do {! ///////phase.monad} + [@loop (\ ! map ..loop_name /////generation.next) + initsO+ (monad.map ! (generate archive) initsS+) + [loop_name bodyO] (/////generation.with_new_context archive + (do ! + [@loop (\ ! map (|>> ///reference.artifact _.var) + (/////generation.context archive))] + (/////generation.with_anchor @loop + (generate archive bodyS)))) + #let [@loop (_.var (///reference.artifact loop_name)) + locals (|> initsS+ + list.enumeration + (list\map (|>> product.left (n.+ start) //case.register))) + [directive instantiation] (: [Statement Expression] + (case (|> (synthesis.path/then bodyS) + //case.dependencies + (set.from_list _.hash) + (set.difference (set.from_list _.hash locals)) + set.to_list) + #.Nil + [(_.function @loop locals + (_.return bodyO)) + @loop] + + foreigns + (let [@context (_.var (format (///reference.artifact loop_name) "_context"))] + [(_.function @context foreigns + ($_ _.then + (<| (_.local_function @loop locals) + (_.return bodyO)) + (_.return @loop) + )) + (_.apply/* foreigns @context)])))] + _ (/////generation.execute! directive) + _ (/////generation.save! (_.code @loop) directive)] + (wrap (_.apply/* initsO+ instantiation))))) (def: #export (recur generate archive argsS+) (Generator (List Synthesis)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux index 72f8576f5..d7b0f1cd3 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux @@ -58,7 +58,8 @@ (def: prefix "LuxRuntime") -(def: #export unit (_.string /////synthesis.unit)) +(def: #export unit + (_.string /////synthesis.unit)) (def: (flag value) (-> Bit Literal) @@ -232,7 +233,7 @@ (runtime: (array//concat left right) (with_vars [temp idx] (let [copy! (function (_ input output) - (<| (_.for_step idx (_.int +1) (_.the "n" input) (_.int +1)) + (<| (_.for_step idx (_.int +1) (_.length input) (_.int +1)) (_.statement (|> (_.var "table.insert") (_.apply/* (list output (_.nth idx input)))))))] ($_ _.then (_.let (list temp) (_.array (list))) @@ -277,7 +278,7 @@ @lux//program_args )) -(runtime: (i64//logic_right_shift param subject) +(runtime: (i64//right_shift param subject) (let [mask (|> (_.int +1) (_.bit_shl (_.- param (_.int +64))) (_.- (_.int +1)))] @@ -288,7 +289,7 @@ (def: runtime//i64 Statement ($_ _.then - @i64//logic_right_shift + @i64//right_shift )) (runtime: (text//index subject param start) @@ -301,22 +302,16 @@ (_.return (..some idx)))))) (runtime: (text//clip text from to) - (with_vars [size] - ($_ _.then - (_.let (list size) (_.apply/* (list text) (_.var "string.len"))) - (_.if (_.or (_.> size from) - (_.> size to)) - (_.return ..none) - (_.return (..some (_.apply/* (list text from to) (_.var "string.sub"))))) - ))) + (_.return (_.apply/* (list text from to) (_.var "string.sub")))) (runtime: (text//char idx text) (with_vars [char] ($_ _.then (_.let (list char) (_.apply/* (list text idx) (_.var "string.byte"))) (_.if (_.= _.nil char) - (_.return ..none) - (_.return (..some char)))))) + (_.statement (_.apply/* (list (_.string "[Lux Error] Cannot get char from text.")) + (_.var "error"))) + (_.return char))))) (def: runtime//text Statement diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux index a6d60074b..07425c45b 100644 --- a/stdlib/source/lux/type/resource.lux +++ b/stdlib/source/lux/type/resource.lux @@ -9,8 +9,8 @@ ["." io (#+ IO)] [concurrency ["." promise (#+ Promise)]] - ["p" parser - ["s" code (#+ Parser)]]] + ["<>" parser + ["<.>" code (#+ Parser)]]] [data ["." identity (#+ Identity)] ["." maybe] @@ -80,25 +80,22 @@ [async Promise promise.monad run_async lift_async] ) -(abstract: #export Ordered []) +(abstract: #export Ordered Any) -(abstract: #export Commutative []) +(abstract: #export Commutative Any) (abstract: #export (Key mode key) - [] + Any (template [<name> <mode>] [(def: <name> - (Ex [k] (-> [] (Key <mode> k))) + (Ex [k] (-> Any (Key <mode> k))) (|>> :abstraction))] [ordered_key Ordered] [commutative_key Commutative] )) -(type: #export OK (Key Ordered)) -(type: #export CK (Key Commutative)) - (abstract: #export (Res key value) value @@ -138,21 +135,22 @@ (def: indices (Parser (List Nat)) - (s.tuple (loop [seen (set.new n.hash)] - (do {! p.monad} - [done? s.end?] - (if done? - (wrap (list)) - (do ! - [head s.nat - _ (p.assert (exception.construct index_cannot_be_repeated head) - (not (set.member? seen head))) - tail (recur (set.add head seen))] - (wrap (list& head tail)))))))) + (<code>.tuple (loop [seen (set.new n.hash)] + (do {! <>.monad} + [done? <code>.end?] + (if done? + (wrap (list)) + (do ! + [head <code>.nat + _ (<>.assert (exception.construct ..index_cannot_be_repeated head) + (not (set.member? seen head))) + tail (recur (set.add head seen))] + (wrap (list& head tail)))))))) (def: (no_op Monad<m>) (All [m] (-> (Monad m) (Linear m Any))) - (function (_ context) (\ Monad<m> wrap [context []]))) + (function (_ context) + (\ Monad<m> wrap [context []]))) (template [<name> <m> <monad>] [(syntax: #export (<name> {swaps ..indices}) @@ -174,8 +172,8 @@ swaps) maybe.assume row.to_list) - g!inputsT+ (list\map (|>> (~) ..CK (`)) g!inputs) - g!outputsT+ (list\map (|>> (~) ..CK (`)) g!outputs)]] + g!inputsT+ (list\map (|>> (~) (..Key ..Commutative) (`)) g!inputs) + g!outputsT+ (list\map (|>> (~) (..Key ..Commutative) (`)) g!outputs)]] (wrap (list (` (: (All [(~+ g!inputs) (~ g!context)] (Procedure (~! <m>) [(~+ g!inputsT+) (~ g!context)] @@ -191,10 +189,10 @@ (def: amount (Parser Nat) - (do p.monad - [raw s.nat - _ (p.assert (exception.construct ..amount_cannot_be_zero []) - (n.> 0 raw))] + (do <>.monad + [raw <code>.nat + _ (<>.assert (exception.construct ..amount_cannot_be_zero []) + (n.> 0 raw))] (wrap raw))) (template [<name> <m> <monad> <from> <to>] diff --git a/stdlib/source/lux/type/unit.lux b/stdlib/source/lux/type/unit.lux index 0a3d5c61a..b45e32c37 100644 --- a/stdlib/source/lux/type/unit.lux +++ b/stdlib/source/lux/type/unit.lux @@ -103,6 +103,7 @@ (primitive (~ (code.text (scale_name name))) [(~' u)]))) (` (structure: (~+ (|export|.format export)) (~ (code.local_identifier (format "@" name))) (..Scale (~ g!scale)) + (def: (~' scale) (|>> ..out (i.* (~ (code.int (.int numerator)))) @@ -165,17 +166,23 @@ (unit: #export Litre) (unit: #export Second) -(structure: #export equivalence (All [unit] (Equivalence (Qty unit))) +(structure: #export equivalence + (All [unit] (Equivalence (Qty unit))) + (def: (= reference sample) (i.= (out reference) (out sample)))) -(structure: #export order (All [unit] (Order (Qty unit))) +(structure: #export order + (All [unit] (Order (Qty unit))) + (def: &equivalence ..equivalence) (def: (< reference sample) (i.< (out reference) (out sample)))) -(structure: #export enum (All [unit] (Enum (Qty unit))) +(structure: #export enum + (All [unit] (Enum (Qty unit))) + (def: &order ..order) (def: succ (|>> ..out inc ..in)) (def: pred (|>> ..out dec ..in))) diff --git a/stdlib/source/program/aedifex/artifact.lux b/stdlib/source/program/aedifex/artifact.lux index 07b53157f..9e87988ea 100644 --- a/stdlib/source/program/aedifex/artifact.lux +++ b/stdlib/source/program/aedifex/artifact.lux @@ -68,12 +68,12 @@ (text.split_all_with ..group_separator) (text.join_with separator))) -(def: #export (uri artifact) - (-> Artifact URI) +(def: #export (uri version artifact) + (-> Version Artifact URI) (let [/ uri.separator group (..directory / (get@ #group artifact)) name (get@ #name artifact) - version (get@ #version artifact) + ## version (get@ #version artifact) identity (..identity artifact)] (%.format group / name / version / identity))) diff --git a/stdlib/source/program/aedifex/artifact/versioning.lux b/stdlib/source/program/aedifex/artifact/versioning.lux index 41b3179d3..dab943145 100644 --- a/stdlib/source/program/aedifex/artifact/versioning.lux +++ b/stdlib/source/program/aedifex/artifact/versioning.lux @@ -89,9 +89,10 @@ (Parser Versioning) (<| (..sub ..<versioning>) ($_ <>.and - (<xml>.somewhere //snapshot.parser) - (<xml>.somewhere ..last_updated_parser) - (<| <xml>.somewhere + (<>.default #//snapshot.Local (<xml>.somewhere //snapshot.parser)) + (<>.default instant.epoch (<xml>.somewhere ..last_updated_parser)) + (<| (<>.default (list)) + <xml>.somewhere (..sub ..<snapshot_versions>) (<>.some //snapshot/version.parser)) ))) diff --git a/stdlib/source/program/aedifex/command/build.lux b/stdlib/source/program/aedifex/command/build.lux index 7241b1de4..388a48c89 100644 --- a/stdlib/source/program/aedifex/command/build.lux +++ b/stdlib/source/program/aedifex/command/build.lux @@ -107,7 +107,7 @@ (All [!] (-> (file.System !) Path Artifact Path)) (let [/ (\ fs separator)] (|> artifact - ///local.uri + (///local.uri (get@ #///artifact.version artifact)) (text.replace_all uri.separator /) (format home /)))) diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux index fe96055ef..758f87ab9 100644 --- a/stdlib/source/program/aedifex/command/deploy.lux +++ b/stdlib/source/program/aedifex/command/deploy.lux @@ -63,12 +63,13 @@ _ (///dependency/deployment.one repository [artifact ///artifact/type.lux_library] - {#///package.origin (#///repository/origin.Remote "") - #///package.library [library - (///dependency/status.verified library)] - #///package.pom [pom - (|> pom - (\ xml.codec encode) - (\ encoding.utf8 encode) - ///dependency/status.verified)]})] + (let [pom_data (|> pom + (\ xml.codec encode) + (\ encoding.utf8 encode))] + {#///package.origin (#///repository/origin.Remote "") + #///package.library [library + (///dependency/status.verified library)] + #///package.pom [pom + pom_data + (///dependency/status.verified pom_data)]}))] (console.write_line //clean.success console))) diff --git a/stdlib/source/program/aedifex/command/deps.lux b/stdlib/source/program/aedifex/command/deps.lux index 71dffeec1..14b5d803f 100644 --- a/stdlib/source/program/aedifex/command/deps.lux +++ b/stdlib/source/program/aedifex/command/deps.lux @@ -3,13 +3,16 @@ [abstract [monad (#+ do)]] [control + ["." exception] [concurrency ["." promise (#+ Promise)]]] [data [collection ["." set (#+ Set)] ["." list ("#\." fold)] - ["." dictionary]]] + ["." dictionary]] + [text + ["%" format (#+ format)]]] [world [program (#+ Program)] ["." file] @@ -18,22 +21,39 @@ ["#." clean] ["/#" // #_ [command (#+ Command)] - [artifact (#+ Artifact)] [repository (#+ Repository)] ["#" profile] ["#." action (#+ Action)] - ["#." dependency #_ + ["#." artifact (#+ Artifact)] + ["#." dependency (#+ Dependency) ["#/." resolution (#+ Resolution)] ["#/." deployment]]]]) +(def: %dependency + (%.Format Dependency) + (|>> (get@ #///dependency.artifact) + ///artifact.format + %.text)) + (def: #export (do! console local remotes profile) (-> (Console Promise) (Repository Promise) (List (Repository Promise)) (Command Resolution)) - (do ///action.monad + (do promise.monad [#let [dependencies (set.to_list (get@ #///.dependencies profile))] - cache (///dependency/resolution.all (list local) dependencies ///dependency/resolution.empty) - resolution (///dependency/resolution.all remotes dependencies cache) - cached (|> (dictionary.keys cache) - (list\fold dictionary.remove resolution) - (///dependency/deployment.all local)) - _ (console.write_line //clean.success console)] - (wrap resolution))) + [local_successes local_failures cache] (///dependency/resolution.all (list local) dependencies ///dependency/resolution.empty) + [remote_successes remote_failures resolution] (///dependency/resolution.all remotes dependencies cache)] + (do ///action.monad + [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 %dependency local_successes)] + ["Local failures" (exception.enumerate %dependency local_failures)] + ["Remote successes" (let [remote_successes (|> remote_successes + (set.from_list ///dependency.hash) + (set.difference (set.from_list ///dependency.hash local_successes)) + set.to_list)] + (exception.enumerate %dependency remote_successes))] + ["Remote failures" (exception.enumerate %dependency remote_failures)]) + console)] + (wrap resolution)))) diff --git a/stdlib/source/program/aedifex/command/install.lux b/stdlib/source/program/aedifex/command/install.lux index b051a4900..35ffcf72f 100644 --- a/stdlib/source/program/aedifex/command/install.lux +++ b/stdlib/source/program/aedifex/command/install.lux @@ -54,15 +54,17 @@ (do ///action.monad [package (export.library system (set.to_list (get@ #/.sources profile))) pom (\ promise.monad wrap (///pom.write profile)) - _ (///dependency/deployment.one repository [identity ///artifact/type.lux_library] - {#///package.origin (#///origin.Local "") - #///package.library (let [library (binary.run tar.writer package)] - [library (///dependency/status.verified library)]) - #///package.pom [pom - (|> pom - (\ xml.codec encode) - (\ encoding.utf8 encode) - ///dependency/status.verified)]})] + _ (///dependency/deployment.one repository + [identity ///artifact/type.lux_library] + (let [pom_data (|> pom + (\ xml.codec encode) + (\ encoding.utf8 encode))] + {#///package.origin (#///origin.Local "") + #///package.library (let [library (binary.run tar.writer package)] + [library (///dependency/status.verified library)]) + #///package.pom [pom + pom_data + (///dependency/status.verified pom_data)]}))] (console.write_line //clean.success console)) _ diff --git a/stdlib/source/program/aedifex/dependency/deployment.lux b/stdlib/source/program/aedifex/dependency/deployment.lux index 1f3e776a9..04b82d7e2 100644 --- a/stdlib/source/program/aedifex/dependency/deployment.lux +++ b/stdlib/source/program/aedifex/dependency/deployment.lux @@ -32,7 +32,11 @@ ["#." package (#+ Package)] ["#." artifact (#+ Artifact) ["#/." type] - ["#/." extension (#+ Extension)]] + ["#/." extension (#+ Extension)] + ["#/." versioning] + ["#/." snapshot + ["#/." version (#+ Version) + ["#/." value]]]] ["#." metadata ["#/." artifact] ["#/." snapshot]] @@ -42,9 +46,9 @@ ["#." repository (#+ Repository) ["#/." origin]]]) -(def: (with_status repository [artifact type] [data status]) - (-> (Repository Promise) Dependency [Binary Status] (Promise (Try Any))) - (let [artifact (format (///artifact.uri artifact) +(def: (with_status repository version_template [artifact type] [data status]) + (-> (Repository Promise) ///artifact.Version Dependency [Binary Status] (Promise (Try Any))) + (let [artifact (format (///artifact.uri version_template artifact) (///artifact/extension.extension type)) deploy_hash (: (All [h] (-> (Codec Text (Hash h)) Extension (Hash h) (Promise (Try Any)))) (function (_ codec extension hash) @@ -91,29 +95,44 @@ (def: #export (one repository [artifact type] package) (-> (Repository Promise) Dependency Package (Promise (Try Artifact))) (do {! promise.monad} - [now (promise.future instant.now)] + [now (promise.future instant.now) + #let [version_template (get@ #///artifact.version artifact)]] (do (try.with !) - [_ (with_status repository [artifact type] (get@ #///package.library package)) + [_ (with_status repository version_template [artifact type] (get@ #///package.library package)) - _ (let [[pom status] (get@ #///package.pom package)] + _ (let [[pom pom_data status] (get@ #///package.pom package)] (with_status repository + version_template [artifact ///artifact/type.pom] - [(|> pom (\ xml.codec encode) (\ encoding.utf8 encode)) + [pom_data 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 #///metadata/snapshot.time_stamp] now) - (update@ [#///metadata/snapshot.versioning #///metadata/snapshot.build] inc) - (set@ [#///metadata/snapshot.versioning #///metadata/snapshot.snapshot] - (list\compose (..artifacts type (product.right (get@ #///package.library package))) - (..artifacts ///artifact/type.pom (product.right (get@ #///package.pom package))))) + (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)) - project (///metadata/artifact.read repository artifact) - #let [version (get@ #///artifact.version artifact)] _ (|> project - (set@ #///metadata/artifact.versions (list version)) + (set@ #///metadata/artifact.versions (list version_template)) (set@ #///metadata/artifact.last_updated now) (///metadata/artifact.write repository artifact))] (wrap artifact)))) diff --git a/stdlib/source/program/aedifex/dependency/resolution.lux b/stdlib/source/program/aedifex/dependency/resolution.lux index e6b24b152..1be540298 100644 --- a/stdlib/source/program/aedifex/dependency/resolution.lux +++ b/stdlib/source/program/aedifex/dependency/resolution.lux @@ -1,12 +1,13 @@ (.module: [lux (#- Name) + ["." debug] ["." host (#+ import:)] [abstract [codec (#+ Codec)] [equivalence (#+ Equivalence)] [monad (#+ Monad do)]] [control - ["." try (#+ Try)] + ["." try (#+ Try) ("#\." functor)] ["." exception (#+ Exception exception:)] ["<>" parser ["<.>" xml (#+ Parser)]] @@ -16,14 +17,15 @@ ["." binary (#+ Binary)] ["." name] ["." maybe] - [text + ["." text ["%" format (#+ format)] ["." encoding]] [format ["." xml (#+ Tag XML)]] [collection ["." dictionary (#+ Dictionary)] - ["." set]]] + ["." set] + ["." list ("#\." functor monoid)]]] [math [number ["n" nat] @@ -38,11 +40,17 @@ ["#." hash (#+ Hash SHA-1 MD5)] ["#." pom] ["#." package (#+ Package)] - ["#." artifact (#+ Artifact) - ["#/." extension (#+ Extension)]] + ["#." artifact (#+ Version Artifact) + ["#/." extension (#+ Extension)] + ["#/." versioning] + ["." snapshot + [version + ["." value]]]] ["#." repository (#+ Repository) ["#/." remote (#+ Address)] - ["#/." origin (#+ Origin)]]]]) + ["#/." origin (#+ Origin)]] + ["#." metadata + ["#/." snapshot]]]]) (template [<name>] [(exception: #export (<name> {artifact Artifact} {extension Extension} {hash Text}) @@ -55,19 +63,30 @@ [md5_does_not_match] ) -(def: (verified_hash library repository artifact extension hash codec exception) +(import: java/lang/String + ["#::." + (trim [] java/lang/String)]) + +(def: (verified_hash library repository version_template artifact extension hash codec exception) (All [h] - (-> Binary (Repository Promise) Artifact Extension + (-> Binary (Repository Promise) Version Artifact Extension (-> Binary (Hash h)) (Codec Text (Hash h)) (Exception [Artifact Extension Text]) (Promise (Try (Maybe (Hash h)))))) (do promise.monad - [?actual (\ repository download (///repository/remote.uri artifact extension))] + [?actual (\ repository download (///repository/remote.uri version_template artifact extension))] (case ?actual (#try.Success actual) - (wrap (do try.monad - [output (\ encoding.utf8 decode actual) - actual (\ codec decode output) + (wrap (do {! try.monad} + [output (\ ! map (|>> (:coerce java/lang/String) + java/lang/String::trim + (:coerce Text)) + (\ encoding.utf8 decode actual)) + actual (|> output + (text.split_all_with " ") + list.head + (maybe.default output) + (\ codec decode)) _ (exception.assert exception [artifact extension output] (\ ///hash.equivalence = (hash library) actual))] (wrap (#.Some actual)))) @@ -75,15 +94,15 @@ (#try.Failure error) (wrap (#try.Success #.None))))) -(def: (hashed repository artifact extension) - (-> (Repository Promise) Artifact Extension (Promise (Try [Binary Status]))) +(def: (hashed repository version_template artifact extension) + (-> (Repository Promise) Version Artifact Extension (Promise (Try [Binary Status]))) (do (try.with promise.monad) - [data (\ repository download (///repository/remote.uri artifact extension)) + [data (\ repository download (///repository/remote.uri version_template artifact extension)) ?sha-1 (..verified_hash data - repository artifact (format extension ///artifact/extension.sha-1) + repository version_template artifact (format extension ///artifact/extension.sha-1) ///hash.sha-1 ///hash.sha-1_codec ..sha-1_does_not_match) ?md5 (..verified_hash data - repository artifact (format extension ///artifact/extension.md5) + repository version_template artifact (format extension ///artifact/extension.md5) ///hash.md5 ///hash.md5_codec ..md5_does_not_match)] (wrap [data (case [?sha-1 ?md5] [(#.Some sha-1) (#.Some md5)] @@ -103,16 +122,21 @@ (let [[artifact type] dependency extension (///artifact/extension.extension type)] (do (try.with promise.monad) - [[pom pom_status] (..hashed repository artifact ///artifact/extension.pom) - library_&_status (..hashed repository artifact extension)] + [snapshot (///metadata/snapshot.read repository artifact) + #let [version_template (get@ [#///metadata/snapshot.artifact #///artifact.version] snapshot) + artifact_version (value.format {#value.version version_template + #value.snapshot (get@ [#///metadata/snapshot.versioning #///artifact/versioning.snapshot] snapshot)}) + artifact (set@ #///artifact.version artifact_version artifact)] + [pom_data pom_status] (..hashed repository version_template artifact ///artifact/extension.pom) + library_&_status (..hashed repository version_template artifact extension)] (\ promise.monad wrap (do try.monad - [pom (\ encoding.utf8 decode pom) + [pom (\ encoding.utf8 decode pom_data) pom (\ xml.codec decode pom) - profile (<xml>.run ///pom.parser pom)] + profile (<xml>.run ///pom.parser (list pom))] (wrap {#///package.origin (#///repository/origin.Remote "") #///package.library library_&_status - #///package.pom [pom pom_status]})))))) + #///package.pom [pom pom_data pom_status]})))))) (type: #export Resolution (Dictionary Dependency Package)) @@ -149,21 +173,54 @@ (any alternatives dependency))))) (def: #export (all repositories dependencies resolution) - (-> (List (Repository Promise)) (List Dependency) Resolution (Promise (Try Resolution))) - (case dependencies - #.Nil - (\ (try.with promise.monad) wrap resolution) - - (#.Cons head tail) - (do (try.with promise.monad) - [package (case (dictionary.get head resolution) - (#.Some package) - (wrap package) - - #.None - (..any repositories head)) - sub_dependencies (\ promise.monad wrap (///package.dependencies package)) - resolution (|> resolution - (dictionary.put head package) - (all repositories (set.to_list sub_dependencies)))] - (all repositories tail resolution)))) + (-> (List (Repository Promise)) (List Dependency) Resolution + (Promise [(List Dependency) + (List Dependency) + Resolution])) + (loop [repositories repositories + successes (: (List Dependency) (list)) + failures (: (List Dependency) (list)) + dependencies dependencies + resolution resolution] + (case dependencies + #.Nil + (\ promise.monad wrap + [successes failures resolution]) + + (#.Cons head tail) + (case (get@ [#//.artifact #///artifact.version] head) + ## Skip if there is no version + "" (recur repositories + successes + failures + tail + resolution) + _ (do promise.monad + [?package (case (dictionary.get head resolution) + (#.Some package) + (wrap (#try.Success package)) + + #.None + (..any repositories head))] + (case ?package + (#try.Success package) + (let [sub_dependencies (|> package + ///package.dependencies + (try\map set.to_list) + (try.default (list))) + sub_repositories (|> package + ///package.repositories + (try\map set.to_list) + (try.default (list)) + (list\map (|>> (///repository/remote.repository #.None) + ///repository.async)) + (list\compose repositories))] + (|> resolution + (dictionary.put head package) + (recur sub_repositories + (#.Cons head successes) + failures + sub_dependencies))) + + (#try.Failure error) + (wrap [successes (#.Cons head failures) resolution]))))))) diff --git a/stdlib/source/program/aedifex/local.lux b/stdlib/source/program/aedifex/local.lux index 279973c1a..bf8c0f780 100644 --- a/stdlib/source/program/aedifex/local.lux +++ b/stdlib/source/program/aedifex/local.lux @@ -7,7 +7,7 @@ [net ["." uri (#+ URI)]]]] ["." // #_ - ["#." artifact (#+ Artifact)]]) + ["#." artifact (#+ Version Artifact)]]) (def: / uri.separator) @@ -15,7 +15,6 @@ URI (format ".m2" / "repository")) -(def: #export uri - (-> Artifact URI) - (|>> //artifact.uri - (format ..repository /))) +(def: #export (uri version artifact) + (-> Version Artifact URI) + (format ..repository / (//artifact.uri version artifact))) diff --git a/stdlib/source/program/aedifex/metadata.lux b/stdlib/source/program/aedifex/metadata.lux index 0eca976c0..08dab9ed3 100644 --- a/stdlib/source/program/aedifex/metadata.lux +++ b/stdlib/source/program/aedifex/metadata.lux @@ -3,6 +3,10 @@ [world [file (#+ Path)]]]) -(def: #export file +(def: #export remote_file Path "maven-metadata.xml") + +(def: #export local_file + Path + "maven-metadata-local.xml") diff --git a/stdlib/source/program/aedifex/metadata/artifact.lux b/stdlib/source/program/aedifex/metadata/artifact.lux index c1d98a8b5..811713427 100644 --- a/stdlib/source/program/aedifex/metadata/artifact.lux +++ b/stdlib/source/program/aedifex/metadata/artifact.lux @@ -173,7 +173,7 @@ (let [/ uri.separator group (///artifact.directory / (get@ #///artifact.group artifact)) name (get@ #///artifact.name artifact)] - (%.format group / name / //.file))) + (%.format group / name / //.remote_file))) (def: epoch Instant @@ -189,7 +189,7 @@ (do> try.monad [(\ encoding.utf8 decode)] [(\ xml.codec decode)] - [(<xml>.run ..parser)]))) + [list (<xml>.run ..parser)]))) (#try.Failure error) (wrap (#try.Success diff --git a/stdlib/source/program/aedifex/metadata/snapshot.lux b/stdlib/source/program/aedifex/metadata/snapshot.lux index 99ad25470..fa1bcb750 100644 --- a/stdlib/source/program/aedifex/metadata/snapshot.lux +++ b/stdlib/source/program/aedifex/metadata/snapshot.lux @@ -4,7 +4,7 @@ [monad (#+ do)] [equivalence (#+ Equivalence)]] [control - [pipe (#+ do>)] + [pipe (#+ do> case>)] ["." try (#+ Try)] ["." exception (#+ exception:)] ["<>" parser @@ -33,96 +33,25 @@ [net ["." uri (#+ URI)]]]] ["." // - ["." artifact] ["/#" // #_ [repository (#+ Repository)] ["#." artifact (#+ Group Name Version Artifact) - ["#/." type (#+ Type)]]]]) - -(def: snapshot - "SNAPSHOT") - -(type: #export Time_Stamp - Instant) - -(type: #export Build - Nat) - -(type: #export Versioning - {#time_stamp Time_Stamp - #build Build - #snapshot (List Type)}) - -(type: #export Value - [Version Time_Stamp Build]) + ["#/." type (#+ Type)] + ["#/." versioning (#+ Versioning)] + ["#/." snapshot + ["#/." version]]]]]) (type: #export Metadata {#artifact Artifact #versioning Versioning}) -(def: (pad value) - (-> Nat Text) - (if (n.< 10 value) - (%.format "0" (%.nat value)) - (%.nat value))) - -(def: (date_format value) - (%.Format Date) - (%.format (|> value date.year year.value .nat %.nat) - (|> value date.month month.number ..pad) - (|> value date.day_of_month ..pad))) - -(def: (time_format value) - (%.Format Time) - (let [(^slots [#time.hour #time.minute #time.second]) (time.clock value)] - (%.format (..pad hour) - (..pad minute) - (..pad second)))) - -(def: (instant_format value) - (%.Format Instant) - (%.format (..date_format (instant.date value)) - (..time_format (instant.time value)))) - -(template [<separator> <name>] - [(def: <name> - <separator>)] - - ["." time_stamp_separator] - ["-" value_separator] - ) - -(def: (time_stamp_format value) - (%.Format Time_Stamp) - (%.format (..date_format (instant.date value)) - ..time_stamp_separator - (..time_format (instant.time value)))) - -(def: (value_format [version time_stamp build]) - (%.Format Value) - (%.format (text.replace_all ..snapshot - (..time_stamp_format time_stamp) - version) - ..value_separator - (%.nat build))) - (template [<definition> <tag>] [(def: <definition> xml.Tag ["" <tag>])] [<group> "groupId"] [<name> "artifactId"] [<version> "version"] - [<last_updated> "lastUpdated"] [<metadata> "metadata"] - [<versioning> "versioning"] - [<snapshot> "snapshot"] - [<timestamp> "timestamp"] - [<build_number> "buildNumber"] - [<snapshot_versions> "snapshotVersions"] - [<snapshot_version> "snapshotVersion"] - [<extension> "extension"] - [<value> "value"] - [<updated> "updated"] ) (template [<name> <type> <tag> <pre>] @@ -133,33 +62,8 @@ [format_group Group ..<group> (|>)] [format_name Name ..<name> (|>)] [format_version Version ..<version> (|>)] - [format_last_updated Instant ..<last_updated> ..instant_format] - [format_time_stamp Instant ..<timestamp> ..time_stamp_format] - [format_build_number Nat ..<build_number> %.nat] - [format_extension Type ..<extension> (|>)] - [format_value Value ..<value> ..value_format] - [format_updated Instant ..<updated> ..instant_format] ) -(def: (format_snapshot value type) - (-> Value Type XML) - (<| (#xml.Node ..<snapshot_version> xml.attributes) - (list (..format_extension type) - (..format_value value) - (let [[version time_stamp build] value] - (..format_updated time_stamp))))) - -(def: (format_versioning version (^slots [#time_stamp #build #snapshot])) - (-> Version Versioning XML) - (<| (#xml.Node ..<versioning> xml.attributes) - (list (<| (#xml.Node ..<snapshot> xml.attributes) - (list (..format_time_stamp time_stamp) - (..format_build_number build))) - (..format_last_updated time_stamp) - (<| (#xml.Node ..<snapshot_versions> xml.attributes) - (list\map (..format_snapshot [version time_stamp build]) - snapshot))))) - (def: #export (format (^slots [#artifact #versioning])) (-> Metadata XML) (let [(^slots [#///artifact.group #///artifact.name #///artifact.version]) artifact] @@ -168,7 +72,7 @@ (list (..format_group group) (..format_name name) (..format_version version) - (..format_versioning version versioning))))) + (///artifact/versioning.format versioning))))) (def: (sub tag parser) (All [a] (-> xml.Tag (Parser a) (Parser a))) @@ -180,135 +84,46 @@ (-> xml.Tag (Parser Text)) (..sub tag <xml>.text)) -(def: date_parser - (<text>.Parser Date) - (do <>.monad - [year (<>.codec n.decimal (<text>.exactly 4 <text>.decimal)) - year (<>.lift (year.year (.int year))) - month (<>.codec n.decimal (<text>.exactly 2 <text>.decimal)) - month (<>.lift (month.by_number month)) - day_of_month (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))] - (<>.lift (date.date year month day_of_month)))) - -(def: time_parser - (<text>.Parser Time) - (do <>.monad - [hour (<>.codec n.decimal (<text>.exactly 2 <text>.decimal)) - minute (<>.codec n.decimal (<text>.exactly 2 <text>.decimal)) - second (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))] - (<>.lift (time.time - {#time.hour hour - #time.minute minute - #time.second second - #time.milli_second 0})))) - -(def: last_updated_parser - (Parser Instant) - (<text>.embed (do <>.monad - [date ..date_parser - time ..time_parser] - (wrap (instant.from_date_time date time))) - (..text ..<last_updated>))) - -(def: time_stamp_parser - (Parser Time_Stamp) - (<text>.embed (do <>.monad - [date ..date_parser - _ (<text>.this ..time_stamp_separator) - time ..time_parser] - (wrap (instant.from_date_time date time))) - (..text ..<timestamp>))) - -(def: build_parser - (Parser Build) - (<text>.embed (<>.codec n.decimal - (<text>.many <text>.decimal)) - (..text ..<build_number>))) - -(exception: #export (time_stamp_mismatch {expected Time_Stamp} {actual Text}) - (exception.report - ["Expected time-stamp" (instant_format expected)] - ["Actual time-stamp" actual])) - -(exception: #export (value_mismatch {expected Value} {actual Text}) - (exception.report - ["Expected" (..value_format expected)] - ["Actual" actual])) - -(def: (snapshot_parser expected) - (-> Value (Parser Type)) - (<| (..sub ..<snapshot_version>) - (do <>.monad - [#let [[version time_stamp build] expected] - updated (<xml>.somewhere (..text ..<updated>)) - _ (<>.assert (exception.construct ..time_stamp_mismatch [time_stamp updated]) - (\ text.equivalence = (instant_format time_stamp) updated)) - actual (<xml>.somewhere (..text ..<value>)) - _ (<>.assert (exception.construct ..value_mismatch [expected actual]) - (\ text.equivalence = (..value_format expected) actual))] - (<xml>.somewhere (..text ..<extension>))))) - -(def: (versioning_parser version) - (-> Version (Parser Versioning)) - (<| (..sub ..<versioning>) - (do <>.monad - [[time_stamp build] (<| <xml>.somewhere - (..sub ..<snapshot>) - (<>.and (<xml>.somewhere ..time_stamp_parser) - (<xml>.somewhere ..build_parser))) - last_updated (<xml>.somewhere ..last_updated_parser) - _ (<>.assert (exception.construct ..time_stamp_mismatch [time_stamp (instant_format last_updated)]) - (\ instant.equivalence = time_stamp last_updated)) - snapshot (<| <xml>.somewhere - (..sub ..<snapshot_versions>) - (<>.some (..snapshot_parser [version time_stamp build])))] - (wrap {#time_stamp time_stamp - #build build - #snapshot snapshot})))) - (def: #export parser (Parser Metadata) (<| (..sub ..<metadata>) - (do <>.monad + (do {! <>.monad} [group (<xml>.somewhere (..text ..<group>)) name (<xml>.somewhere (..text ..<name>)) version (<xml>.somewhere (..text ..<version>)) - versioning (<xml>.somewhere (..versioning_parser version))] + versioning (\ ! map + (update@ #///artifact/versioning.versions + (: (-> (List ///artifact/snapshot/version.Version) + (List ///artifact/snapshot/version.Version)) + (|>> (case> (^ (list)) + (list {#///artifact/snapshot/version.extension ///artifact/type.jvm_library + #///artifact/snapshot/version.value version + #///artifact/snapshot/version.updated instant.epoch}) + + versions + versions)))) + (<xml>.somewhere ///artifact/versioning.parser))] (wrap {#artifact {#///artifact.group group #///artifact.name name #///artifact.version version} #versioning versioning})))) -(def: versioning_equivalence - (Equivalence Versioning) - ($_ product.equivalence - instant.equivalence - n.equivalence - (list.equivalence text.equivalence) - )) - (def: #export equivalence (Equivalence Metadata) ($_ product.equivalence ///artifact.equivalence - ..versioning_equivalence + ///artifact/versioning.equivalence )) (def: #export (uri artifact) (-> Artifact URI) (let [/ uri.separator - version (get@ #///artifact.version artifact) - artifact (///artifact.uri artifact)] - (%.format artifact / version / //.file))) - -(def: epoch - Instant - (instant.from_millis +0)) - -(def: init_versioning - {#time_stamp ..epoch - #build 0 - #snapshot (list)}) + group (|> artifact + (get@ #///artifact.group) + (///artifact.directory /)) + name (get@ #///artifact.name artifact) + version (get@ #///artifact.version artifact)] + (%.format group / name / version / //.remote_file))) (def: #export (read repository artifact) (-> (Repository Promise) Artifact (Promise (Try Metadata))) @@ -320,12 +135,12 @@ (do> try.monad [(\ encoding.utf8 decode)] [(\ xml.codec decode)] - [(<xml>.run ..parser)]))) + [list (<xml>.run ..parser)]))) (#try.Failure error) (wrap (#try.Success {#artifact artifact - #versioning ..init_versioning}))))) + #versioning ///artifact/versioning.init}))))) (def: #export (write repository artifact metadata) (-> (Repository Promise) Artifact Metadata (Promise (Try Any))) diff --git a/stdlib/source/program/aedifex/package.lux b/stdlib/source/program/aedifex/package.lux index f6ba87078..445c92987 100644 --- a/stdlib/source/program/aedifex/package.lux +++ b/stdlib/source/program/aedifex/package.lux @@ -10,6 +10,8 @@ ["." sum] ["." product] ["." binary (#+ Binary)] + [text + ["." encoding]] [format ["." xml (#+ XML)]] [collection @@ -21,12 +23,13 @@ [dependency (#+ Dependency) ["#." status (#+ Status)]] [repository + [remote (#+ Address)] ["#." origin (#+ Origin)]]]) (type: #export Package {#origin Origin #library [Binary Status] - #pom [XML Status]}) + #pom [XML Binary Status]}) (template [<name> <tag>] [(def: #export (<name> package) @@ -46,19 +49,35 @@ (-> XML Binary Package) {#origin (#//origin.Local "") #library [library #//status.Unverified] - #pom [pom #//status.Unverified]}) + #pom [pom + (|> pom (\ xml.codec encode) (\ encoding.utf8 encode)) + #//status.Unverified]}) (def: #export dependencies (-> Package (Try (Set Dependency))) (|>> (get@ #pom) product.left + list (<xml>.run //pom.parser) (try\map (get@ #/.dependencies)))) +(def: #export repositories + (-> Package (Try (Set Address))) + (|>> (get@ #pom) + product.left + list + (<xml>.run //pom.parser) + (try\map (get@ #/.repositories)))) + (def: #export equivalence (Equivalence Package) ($_ product.equivalence //origin.equivalence - (product.equivalence binary.equivalence //status.equivalence) - (product.equivalence xml.equivalence //status.equivalence) + ($_ product.equivalence + binary.equivalence + //status.equivalence) + ($_ product.equivalence + xml.equivalence + binary.equivalence + //status.equivalence) )) diff --git a/stdlib/source/program/aedifex/parser.lux b/stdlib/source/program/aedifex/parser.lux index 4a21b341a..411b4665b 100644 --- a/stdlib/source/program/aedifex/parser.lux +++ b/stdlib/source/program/aedifex/parser.lux @@ -171,6 +171,9 @@ (<>.and <c>.text ..repository)))) +(def: default_repository + "https://repo1.maven.org/maven2/") + (def: profile (Parser /.Profile) (do {! <>.monad} @@ -190,7 +193,8 @@ ^repositories (: (Parser (Set //repository.Address)) (|> (..plural input "repositories" ..repository) (\ ! map (set.from_list text.hash)) - (<>.default (set.new text.hash)))) + (<>.default (set.new text.hash)) + (\ ! map (set.add ..default_repository)))) ^dependencies (: (Parser (Set //dependency.Dependency)) (|> (..plural input "dependencies" ..dependency) (\ ! map (set.from_list //dependency.hash)) diff --git a/stdlib/source/program/aedifex/pom.lux b/stdlib/source/program/aedifex/pom.lux index f085e2808..f105f07b6 100644 --- a/stdlib/source/program/aedifex/pom.lux +++ b/stdlib/source/program/aedifex/pom.lux @@ -11,6 +11,7 @@ [data ["." name] ["." maybe ("#\." functor)] + ["." text] [format ["_" xml (#+ Tag XML)]] [collection @@ -150,8 +151,8 @@ (<>.and <xml>.tag (<xml>.children <xml>.text))) -(def: parse_dependency - (Parser Dependency) +(def: (parse_dependency own_version parent_version) + (-> Text Text (Parser Dependency)) (do {! <>.monad} [properties (\ ! map (dictionary.from_list name.hash) (<xml>.children (<>.some ..parse_property)))] @@ -159,28 +160,47 @@ try.from_maybe (do maybe.monad [group (dictionary.get ["" ..group_tag] properties) - artifact (dictionary.get ["" ..artifact_tag] properties) - version (dictionary.get ["" ..version_tag] properties)] + artifact (dictionary.get ["" ..artifact_tag] properties)] (wrap {#//dependency.artifact {#//artifact.group group #//artifact.name artifact - #//artifact.version version} + #//artifact.version (|> properties + (dictionary.get ["" ..version_tag]) + (maybe.default "") + (text.replace_all "${project.version}" own_version) + (text.replace_all "${project.parent.version}" parent_version))} #//dependency.type (|> properties (dictionary.get ["" "type"]) - (maybe.default //artifact/type.lux_library))}))))) + (maybe.default //artifact/type.jvm_library))}))))) -(def: parse_dependencies - (Parser (List Dependency)) +(def: (parse_dependencies own_version parent_version) + (-> Text Text (Parser (List Dependency))) (do {! <>.monad} [_ (<xml>.node ["" ..dependencies_tag])] - (<xml>.children (<>.some ..parse_dependency)))) + (<xml>.children (<>.some (..parse_dependency own_version parent_version))))) + +(def: own_version + (Parser Text) + (do <>.monad + [_ (<xml>.node ["" ..version_tag])] + (<xml>.children <xml>.text))) + +(def: parent_version + (Parser Text) + (do <>.monad + [_ (<xml>.node ["" "parent"])] + ..own_version)) (def: #export parser (Parser /.Profile) (do {! <>.monad} - [_ (<xml>.node ["" ..project_tag])] + [own_version (<>.default "" (<xml>.somewhere ..own_version)) + parent_version (<>.default "" (<xml>.somewhere ..parent_version)) + _ (<xml>.node ["" ..project_tag])] (<xml>.children (do ! - [dependencies (<xml>.somewhere ..parse_dependencies) + [dependencies (|> (..parse_dependencies own_version parent_version) + <xml>.somewhere + (<>.default (list))) _ (<>.some <xml>.ignore)] (wrap (|> (\ /.monoid identity) (update@ #/.dependencies (function (_ empty) diff --git a/stdlib/source/program/aedifex/repository/local.lux b/stdlib/source/program/aedifex/repository/local.lux index f313b3176..7ac384efa 100644 --- a/stdlib/source/program/aedifex/repository/local.lux +++ b/stdlib/source/program/aedifex/repository/local.lux @@ -19,7 +19,8 @@ ["." uri (#+ URI)]]]] ["." // ["/#" // #_ - ["#." local]]]) + ["#." local] + ["#." metadata]]]) (def: (root /) (-> Text Path) @@ -29,18 +30,23 @@ (-> Text URI Path) (text.replace_all uri.separator)) -(def: (file program system uri) +(def: (file program system create? uri) (-> (Program Promise) (file.System Promise) + Bit URI (Promise (Try (File Promise)))) (do {! promise.monad} - [home (\ program home []) + [#let [uri (text.replace_once ///metadata.remote_file ///metadata.local_file uri)] + home (\ program home []) #let [/ (\ system separator) absolute_path (format home / (..root /) / (..path / uri))]] - (do {! (try.with !)} - [_ (: (Promise (Try Path)) - (file.make_directories promise.monad system (file.parent system absolute_path)))] + (if create? + (do {! (try.with !)} + [_ (: (Promise (Try Path)) + (file.make_directories promise.monad system (file.parent system absolute_path)))] + (: (Promise (Try (File Promise))) + (file.get_file promise.monad system absolute_path))) (: (Promise (Try (File Promise))) (!.use (\ system file) absolute_path))))) @@ -49,10 +55,10 @@ (def: (download uri) (do {! (try.with promise.monad)} - [file (..file program system uri)] + [file (..file program system false uri)] (!.use (\ file content) []))) (def: (upload uri content) (do {! (try.with promise.monad)} - [file (..file program system uri)] + [file (..file program system true uri)] (!.use (\ file over_write) [content])))) diff --git a/stdlib/source/program/aedifex/repository/remote.lux b/stdlib/source/program/aedifex/repository/remote.lux index 4979e5429..4b61bc36c 100644 --- a/stdlib/source/program/aedifex/repository/remote.lux +++ b/stdlib/source/program/aedifex/repository/remote.lux @@ -26,7 +26,7 @@ ["." // ["#." identity (#+ Identity)] ["/#" // #_ - ["#." artifact (#+ Artifact) + ["#." artifact (#+ Version Artifact) [extension (#+ Extension)]]]]) (type: #export Address @@ -75,9 +75,9 @@ (exception.report ["Code" (%.int code)])) -(def: #export (uri artifact extension) - (-> Artifact Extension URI) - (format (///artifact.uri artifact) extension)) +(def: #export (uri version_template artifact extension) + (-> Version Artifact Extension URI) + (format (///artifact.uri version_template artifact) extension)) (def: buffer_size (n.* 512 1,024)) @@ -99,19 +99,21 @@ input (|> connection java/net/URLConnection::getInputStream (\ ! map (|>> java/io/BufferedInputStream::new))) - #let [buffer (binary.create ..buffer_size)]] - (loop [output (\ binary.monoid identity)] - (do ! - [bytes_read (java/io/BufferedInputStream::read buffer +0 (.int ..buffer_size) input)] - (case bytes_read - -1 (do ! - [_ (java/lang/AutoCloseable::close input)] - (wrap output)) - _ (if (n.= ..buffer_size bytes_read) - (recur (\ binary.monoid compose output buffer)) + #let [buffer (binary.create ..buffer_size)] + output (loop [output (\ binary.monoid identity)] (do ! - [chunk (\ io.monad wrap (binary.slice 0 (.nat bytes_read) buffer))] - (recur (\ binary.monoid compose output chunk))))))))) + [bytes_read (java/io/BufferedInputStream::read buffer +0 (.int ..buffer_size) input)] + (case bytes_read + -1 (do ! + [_ (java/lang/AutoCloseable::close input)] + (wrap output)) + +0 (recur output) + _ (if (n.= ..buffer_size bytes_read) + (recur (\ binary.monoid compose output buffer)) + (do ! + [chunk (\ io.monad wrap (binary.slice 0 (dec (.nat bytes_read)) buffer))] + (recur (\ binary.monoid compose output chunk)))))))] + (wrap output))) (def: (upload uri content) (case identity diff --git a/stdlib/source/test/aedifex/artifact.lux b/stdlib/source/test/aedifex/artifact.lux index 7d91ebed7..9d2cf9069 100644 --- a/stdlib/source/test/aedifex/artifact.lux +++ b/stdlib/source/test/aedifex/artifact.lux @@ -21,11 +21,9 @@ ["." / #_ ["#." type] ["#." extension] - ["#." value] + ["#." time] ["#." versioning] - ["#." time_stamp - ["#/." date] - ["#/." time]]] + ["#." snapshot]] {#program ["." /]}) @@ -47,9 +45,7 @@ /type.test /extension.test - /value.test + /time.test /versioning.test - /time_stamp.test - /time_stamp/date.test - /time_stamp/time.test + /snapshot.test )))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index f1200381a..a39671ea4 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -93,38 +93,9 @@ (check_neighbors odd? value) (check_neighbors even? value)))))) -(type: (Choice a) - (-> a a a)) - -(type: (Order a) - (-> a a Bit)) - (type: (Equivalence a) (-> a a Bit)) -(def: (choice rand_gen = [< choose]) - (All [a] (-> (Random a) (Equivalence a) [(Order a) (Choice a)] Test)) - (do random.monad - [left rand_gen - right rand_gen - #let [choice (choose left right)]] - ($_ _.and - (_.test "The choice between 2 values is one of them." - (or (= left choice) - (= right choice))) - (_.test "The choice between 2 values implies an order relationship between them." - (if (= left choice) - (< right choice) - (< left choice)))))) - -(def: (minimum_and_maximum rand_gen = min' max') - (All [a] (-> (Random a) (Equivalence a) [(Order a) (Choice a)] [(Order a) (Choice a)] Test)) - ($_ _.and - (<| (_.context "Minimum.") - (choice rand_gen = min')) - (<| (_.context "Maximum.") - (choice rand_gen = max')))) - (def: (conversion rand_gen forward backward =) (All [a b] (-> (Random a) (-> a b) (-> b a) (Equivalence a) Test)) (do random.monad @@ -213,6 +184,18 @@ @.js on_valid_host} on_default)))))) +(def: conversion_tests + Test + (`` ($_ _.and + (~~ (template [<=> <forward> <backward> <gen>] + [(<| (_.context (format (%.name (name_of <forward>)) + " " (%.name (name_of <backward>)))) + (..conversion <gen> <forward> <backward> <=>))] + + [i.= .nat .int (random\map (i.% +1,000,000) random.int)] + [n.= .int .nat (random\map (n.% 1,000,000) random.nat)] + ))))) + (def: sub_tests Test (let [tail (: (List Test) @@ -236,6 +219,7 @@ )))) (def: test + Test (<| (_.context (name.module (name_of /._))) ($_ _.and (<| (_.context "Identity.") @@ -248,30 +232,8 @@ (..even_or_odd random.nat n.even? n.odd?)) (<| (_.context "Integers.") (..even_or_odd random.int i.even? i.odd?)))) - (<| (_.context "Minimum and maximum.") - (`` ($_ _.and - (~~ (template [<=> <lt> <min> <gt> <max> <gen> <context>] - [(<| (_.context <context>) - (..minimum_and_maximum <gen> <=> [<lt> <min>] [<gt> <max>]))] - - [i.= i.< i.min i.> i.max random.int "Integers."] - [n.= n.< n.min n.> n.max random.nat "Natural numbers."] - [r.= r.< r.min r.> r.max random.rev "Revolutions."] - [f.= f.< f.min f.> f.max random.safe_frac "Fractions."] - ))))) (<| (_.context "Conversion.") - (`` ($_ _.and - (~~ (template [<=> <forward> <backward> <gen>] - [(<| (_.context (format (%.name (name_of <forward>)) - " " (%.name (name_of <backward>)))) - (..conversion <gen> <forward> <backward> <=>))] - - [i.= .nat .int (random\map (i.% +1,000,000) random.int)] - [n.= .int .nat (random\map (n.% 1,000,000) random.nat)] - [i.= i.frac f.int (random\map (i.% +1,000,000) random.int)] - [f.= f.int i.frac (random\map (|>> (i.% +1,000,000) i.frac) random.int)] - [r.= r.frac f.rev frac_rev] - ))))) + ..conversion_tests) (<| (_.context "Prelude macros.") ..prelude_macros) (<| (_.context "Templates.") diff --git a/stdlib/source/test/lux/data/name.lux b/stdlib/source/test/lux/data/name.lux index 62c576d27..e413afc95 100644 --- a/stdlib/source/test/lux/data/name.lux +++ b/stdlib/source/test/lux/data/name.lux @@ -42,7 +42,7 @@ (_.for [/.equivalence] ($equivalence.spec /.equivalence (..random sizeM1 sizeS1))) (_.for [/.hash] - (|> (random.ascii 2) + (|> (random.ascii 1) (\ ! map (|>> [""])) ($hash.spec /.hash))) (_.for [/.order] diff --git a/stdlib/source/test/lux/data/text.lux b/stdlib/source/test/lux/data/text.lux index c89ca97ba..983649a89 100644 --- a/stdlib/source/test/lux/data/text.lux +++ b/stdlib/source/test/lux/data/text.lux @@ -240,7 +240,7 @@ (_.for [/.equivalence] ($equivalence.spec /.equivalence (random.ascii 2))) (_.for [/.hash] - (|> (random.ascii 2) + (|> (random.ascii 1) ($hash.spec /.hash))) (_.for [/.order] ($order.spec /.order (random.ascii 2))) diff --git a/stdlib/source/test/lux/macro/code.lux b/stdlib/source/test/lux/macro/code.lux index 0f217e335..730671b5b 100644 --- a/stdlib/source/test/lux/macro/code.lux +++ b/stdlib/source/test/lux/macro/code.lux @@ -170,8 +170,12 @@ [/.local_identifier ..random_text #.Identifier] ))))) (do {! random.monad} - [[original substitute] (random.and ..random ..random) - [sample expected] (..replace_simulation [original substitute])] + [[original substitute] (random.filter (function (_ [original substitute]) + (not (\ /.equivalence = original substitute))) + (random.and ..random ..random)) + [sample expected] (random.filter (function (_ [sample expected]) + (not (\ /.equivalence = sample expected))) + (..replace_simulation [original substitute]))] (_.cover [/.replace] (\ /.equivalence = expected diff --git a/stdlib/source/test/lux/math/modular.lux b/stdlib/source/test/lux/math/modular.lux index b0c69b814..461d5bfac 100644 --- a/stdlib/source/test/lux/math/modular.lux +++ b/stdlib/source/test/lux/math/modular.lux @@ -4,6 +4,7 @@ ["." type ("#\." equivalence)] [abstract [monad (#+ do)] + ["." predicate] {[0 #spec] [/ ["$." equivalence] @@ -41,7 +42,8 @@ [param\\% ($//.random +1,000,000) param (..random param\\%) - subject\\% (random.filter (|>> (//.= param\\%) not) + subject\\% (random.filter (predicate.intersect (|>> //.divisor (i.> +2)) + (|>> (//.= param\\%) not)) ($//.random +1,000,000)) subject (..random subject\\%) another (..random subject\\%)] diff --git a/stdlib/source/test/lux/type/resource.lux b/stdlib/source/test/lux/type/resource.lux index 54150772e..1a56d8d08 100644 --- a/stdlib/source/test/lux/type/resource.lux +++ b/stdlib/source/test/lux/type/resource.lux @@ -1,53 +1,192 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] + ["." meta] [abstract - [monad + ["." monad [indexed (#+ do)]]] [control - ["." io]] + ["." io] + ["." try] + ["." exception (#+ Exception)] + [concurrency + ["." promise]] + [parser + ["<.>" code]]] + [data + ["." text ("#\." equivalence) + ["%" format (#+ format)]]] + ["." macro + [syntax (#+ syntax:)] + ["." code]] [math - [number - ["n" nat]]]] + ["." random]]] {1 ["." / (#+ Res)]}) +(def: pure + Test + (monad.do {! random.monad} + [pre (\ ! map %.nat random.nat) + post (\ ! map %.nat random.nat)] + (_.for [/.Linear /.pure /.run_pure] + (`` ($_ _.and + (~~ (template [<coverage> <bindings>] + [(_.cover <coverage> + (<| (text\= (format pre post)) + /.run_pure + (do /.pure + <bindings> + (wrap (format left right)))))] + + [[/.Affine /.Key /.Res /.Ordered /.ordered_pure + /.Relevant /.read_pure] + [res|left (/.ordered_pure pre) + res|right (/.ordered_pure post) + right (/.read_pure res|right) + left (/.read_pure res|left)]] + [[/.Commutative /.commutative_pure /.exchange_pure] + [res|left (/.commutative_pure pre) + res|right (/.commutative_pure post) + _ (/.exchange_pure [1 0]) + left (/.read_pure res|left) + right (/.read_pure res|right)]] + [[/.group_pure /.un_group_pure] + [res|left (/.commutative_pure pre) + res|right (/.commutative_pure post) + _ (/.group_pure 2) + _ (/.un_group_pure 2) + right (/.read_pure res|right) + left (/.read_pure res|left)]] + [[/.lift_pure] + [left (/.lift_pure pre) + right (/.lift_pure post)]] + )) + ))))) + +(def: sync + Test + (monad.do {! random.monad} + [pre (\ ! map %.nat random.nat) + post (\ ! map %.nat random.nat)] + (_.for [/.Linear /.sync /.run_sync] + (`` ($_ _.and + (~~ (template [<coverage> <bindings>] + [(_.cover <coverage> + (<| (text\= (format pre post)) + io.run + /.run_sync + (do /.sync + <bindings> + (wrap (format left right)))))] + + [[/.Affine /.Key /.Res /.Ordered /.ordered_sync + /.Relevant /.read_sync] + [res|left (/.ordered_sync pre) + res|right (/.ordered_sync post) + right (/.read_sync res|right) + left (/.read_sync res|left)]] + [[/.Commutative /.commutative_sync /.exchange_sync] + [res|left (/.commutative_sync pre) + res|right (/.commutative_sync post) + _ (/.exchange_sync [1 0]) + left (/.read_sync res|left) + right (/.read_sync res|right)]] + [[/.group_sync /.un_group_sync] + [res|left (/.commutative_sync pre) + res|right (/.commutative_sync post) + _ (/.group_sync 2) + _ (/.un_group_sync 2) + right (/.read_sync res|right) + left (/.read_sync res|left)]] + [[/.lift_sync] + [left (/.lift_sync (io.io pre)) + right (/.lift_sync (io.io post))]] + )) + ))))) + +(def: async + Test + (monad.do {! random.monad} + [pre (\ ! map %.nat random.nat) + post (\ ! map %.nat random.nat)] + (_.for [/.Linear /.async /.run_async] + (`` ($_ _.and + (~~ (template [<coverage> <bindings>] + [(wrap (monad.do promise.monad + [outcome (/.run_async + (do /.async + <bindings> + (wrap (format left right))))] + (_.cover' <coverage> + (text\= (format pre post) + outcome))))] + + [[/.Affine /.Key /.Res /.Ordered /.ordered_async + /.Relevant /.read_async] + [res|left (/.ordered_async pre) + res|right (/.ordered_async post) + right (/.read_async res|right) + left (/.read_async res|left)]] + [[/.Commutative /.commutative_async /.exchange_async] + [res|left (/.commutative_async pre) + res|right (/.commutative_async post) + _ (/.exchange_async [1 0]) + left (/.read_async res|left) + right (/.read_async res|right)]] + [[/.group_async /.un_group_async] + [res|left (/.commutative_async pre) + res|right (/.commutative_async post) + _ (/.group_async 2) + _ (/.un_group_async 2) + right (/.read_async res|right) + left (/.read_async res|left)]] + [[/.lift_async] + [left (/.lift_async (promise.resolved pre)) + right (/.lift_async (promise.resolved post))]] + )) + ))))) + +(syntax: (with_error {exception <code>.identifier} to_expand) + (monad.do meta.monad + [[_ _ _ exception] (meta.find_export exception)] + (function (_ compiler) + (#.Right [compiler + (list (code.bit (case ((macro.expand_once to_expand) compiler) + (#try.Success _) + false + + (#try.Failure error) + true)))])))) + (def: #export test Test - (<| (_.context (%.name (name_of /._))) + (<| (_.covering /._) + (_.for [/.Procedure]) ($_ _.and - (_.test "Can produce and consume keys in an ordered manner." - (<| (n.= (n.+ 123 456)) - io.run - /.run_sync - (do /.sync - [res|left (/.ordered_sync 123) - res|right (/.ordered_sync 456) - right (/.read_sync res|right) - left (/.read_sync res|left)] - (wrap (n.+ left right))))) - (_.test "Can exchange commutative keys." - (<| (n.= (n.+ 123 456)) - io.run - /.run_sync - (do /.sync - [res|left (/.commutative_sync 123) - res|right (/.commutative_sync 456) - _ (/.exchange_sync [1 0]) - left (/.read_sync res|left) - right (/.read_sync res|right)] - (wrap (n.+ left right))))) - (_.test "Can group and un-group keys." - (<| (n.= (n.+ 123 456)) - io.run - /.run_sync - (do /.sync - [res|left (/.commutative_sync 123) - res|right (/.commutative_sync 456) - _ (/.group_sync 2) - _ (/.un_group_sync 2) - right (/.read_sync res|right) - left (/.read_sync res|left)] - (wrap (n.+ left right))))) + ..pure + ..sync + ..async + + (_.cover [/.amount_cannot_be_zero] + (`` (and (~~ (template [<group|un_group>] + [(with_error /.amount_cannot_be_zero + (<group|un_group> 0))] + + [/.group_pure] + [/.group_sync] + [/.group_async] + [/.un_group_pure] + [/.un_group_sync] + [/.un_group_async] + ))))) + (_.cover [/.index_cannot_be_repeated] + (`` (and (~~ (template [<exchange>] + [(with_error /.index_cannot_be_repeated + (<exchange> [0 0]))] + + [/.exchange_pure] + [/.exchange_sync] + [/.exchange_async] + ))))) ))) |