diff options
Diffstat (limited to 'stdlib/source')
45 files changed, 1058 insertions, 731 deletions
diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux index 605539376..2791cce92 100644 --- a/stdlib/source/lux/control/concatenative.lux +++ b/stdlib/source/lux/control/concatenative.lux @@ -19,7 +19,8 @@ [syntax (#+ syntax:) ["cs" common ["csr" reader] - ["csw" writer]]]]] + ["csw" writer] + ["|.|" export]]]]] [// ["<>" parser ("#\." monad) ["<c>" code (#+ Parser)]]]) @@ -104,12 +105,12 @@ (wrap (list (` (|> (~! ..begin!) (~+ commands) ((~! ..end!))))))) (syntax: #export (word: - {export csr.export} + {export |export|.parser} {name <c>.local-identifier} {annotations (<>.default cs.empty-annotations csr.annotations)} type {commands (<>.some <c>.any)}) - (wrap (list (` (def: (~+ (csw.export export)) (~ (code.local-identifier name)) + (wrap (list (` (def: (~+ (|export|.write export)) (~ (code.local-identifier name)) (~ (csw.annotations annotations)) (~ type) (|>> (~+ commands))))))) diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux index f9ab10327..66ea24cd8 100644 --- a/stdlib/source/lux/control/concurrency/actor.lux +++ b/stdlib/source/lux/control/concurrency/actor.lux @@ -23,7 +23,8 @@ [syntax (#+ syntax:) ["cs" common ["csr" reader] - ["csw" writer]]]] + ["csw" writer] + ["|.|" export]]]] ["." meta (#+ with-gensyms monad) ["." annotation]] [type (#+ :share) @@ -300,7 +301,7 @@ (message: #export (read! state self Nat) (promise.resolved (#try.Success [state state])))))] (syntax: #export (actor: - {export csr.export} + {export |export|.parser} {[name vars] actor-decl^} {annotations (<>.default cs.empty-annotations csr.annotations)} state-type @@ -313,10 +314,10 @@ [g!type (meta.gensym (format name "-abstract-type")) #let [g!actor (code.local-identifier name) g!vars (list\map code.local-identifier vars)]] - (wrap (list (` ((~! abstract:) (~+ (csw.export export)) ((~ g!type) (~+ g!vars)) + (wrap (list (` ((~! abstract:) (~+ (|export|.write export)) ((~ g!type) (~+ g!vars)) (~ state-type) - (def: (~+ (csw.export export)) (~ g!actor) + (def: (~+ (|export|.write export)) (~ g!actor) (All [(~+ g!vars)] (..Behavior (~ state-type) ((~ g!type) (~+ g!vars)))) {#..on-init (|>> ((~! abstract.:abstraction) (~ g!type))) @@ -360,7 +361,7 @@ (<>.and <c>.identifier (\ <>.monad wrap (list))))) (syntax: #export (message: - {export csr.export} + {export |export|.parser} {signature signature^} {annotations (<>.default cs.empty-annotations csr.annotations)} body) @@ -381,7 +382,7 @@ g!inputsT (|> (get@ #inputs signature) (list\map product.right)) g!state (|> signature (get@ #state) code.local-identifier) g!self (|> signature (get@ #self) code.local-identifier)]] - (wrap (list (` (def: (~+ (csw.export export)) ((~ g!message) (~+ g!inputsC)) + (wrap (list (` (def: (~+ (|export|.write export)) ((~ g!message) (~+ g!inputsC)) (~ (csw.annotations annotations)) (All [(~+ g!all-vars)] (-> (~+ g!inputsT) diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 4257818cf..71bb9ca90 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -19,7 +19,8 @@ [syntax (#+ syntax:) ["sc" common ["scr" reader] - ["scw" writer]]]]] + ["scw" writer] + ["|.|" export]]]]] [// ["//" try (#+ Try)]]) @@ -83,7 +84,7 @@ (#//.Success []) (..throw exception message))) -(syntax: #export (exception: {export scr.export} +(syntax: #export (exception: {export |export|.parser} {t-vars (p.default (list) (s.tuple scr.type-variables))} {[name inputs] (p.either (p.and s.local-identifier (wrap (list))) (s.form (p.and s.local-identifier (p.some scr.typed-input))))} @@ -102,7 +103,7 @@ [current-module meta.current-module-name #let [descriptor ($_ text\compose "{" current-module "." name "}" text.new-line) g!self (code.local-identifier name)]] - (wrap (list (` (def: (~+ (scw.export export)) + (wrap (list (` (def: (~+ (|export|.write export)) (~ g!self) (All [(~+ (scw.type-variables t-vars))] (..Exception [(~+ (list\map (get@ #sc.input-type) inputs))])) diff --git a/stdlib/source/lux/control/parser/type.lux b/stdlib/source/lux/control/parser/type.lux index 3ac8f657d..8ed5004fe 100644 --- a/stdlib/source/lux/control/parser/type.lux +++ b/stdlib/source/lux/control/parser/type.lux @@ -174,7 +174,7 @@ (do {! //.monad} [headT any funcI (\ ! map dictionary.size ..env) - [num-args non-poly] (local (list headT) polymorphic') + [num-args non-poly] (local (list headT) ..polymorphic') env ..env #let [funcL (label funcI) [all-varsL env'] (loop [current-arg 0 @@ -200,11 +200,11 @@ (dictionary.put partial-varI [(#.Parameter partial-varI) partial-varL])) (#.Cons partial-varL all-varsL)))) [all-varsL env']))]] - (|> (do ! - [output poly] - (wrap [funcL all-varsL output])) + (<| (with-env env') (local (list non-poly)) - (with-env env')))) + (do ! + [output poly] + (wrap [funcL all-varsL output]))))) (def: #export (function in-poly out-poly) (All [i o] (-> (Parser i) (Parser o) (Parser [i o]))) @@ -299,12 +299,17 @@ _ (//.fail (exception.construct ..not-named inputT))))) +(template: (|nothing|) + (#.Named ["lux" "Nothing"] + (#.UnivQ #.Nil + (#.Parameter 1)))) + (def: #export (recursive poly) (All [a] (-> (Parser a) (Parser [Code a]))) (do {! //.monad} [headT any] (case (type.un-name headT) - (#.Apply (#.Named ["lux" "Nothing"] _) (#.UnivQ _ headT')) + (^ (#.Apply (|nothing|) (#.UnivQ _ headT'))) (do ! [[recT _ output] (|> poly (with-extension .Nothing) @@ -321,7 +326,7 @@ [env ..env headT any] (case (type.un-name headT) - (^multi (#.Apply (#.Named ["lux" "Nothing"] _) (#.Parameter funcT-idx)) + (^multi (^ (#.Apply (|nothing|) (#.Parameter funcT-idx))) (n.= 0 (adjusted-idx env funcT-idx)) [(dictionary.get 0 env) (#.Some [self-type self-call])]) (wrap self-call) @@ -333,7 +338,7 @@ (Parser Code) (do {! //.monad} [env ..env - [funcT argsT] (apply (//.and any (//.many any))) + [funcT argsT] (..apply (//.and any (//.many any))) _ (local (list funcT) (..parameter! 0)) allC (let [allT (list& funcT argsT)] (|> allT diff --git a/stdlib/source/lux/control/security/capability.lux b/stdlib/source/lux/control/security/capability.lux index a1272b018..2a4e5427b 100644 --- a/stdlib/source/lux/control/security/capability.lux +++ b/stdlib/source/lux/control/security/capability.lux @@ -21,7 +21,8 @@ [syntax (#+ syntax:) [common ["." reader] - ["." writer]]]]]) + ["." writer] + ["|.|" export]]]]]) (abstract: #export (Capability brand input output) (-> input output) @@ -42,7 +43,7 @@ output)) ((:representation capability) input)) - (syntax: #export (capability: {export reader.export} + (syntax: #export (capability: {export |export|.parser} {declaration reader.declaration} {annotations (<>.maybe reader.annotations)} {[forge input output] (<c>.form ($_ <>.and <c>.local-identifier <c>.any <c>.any))}) @@ -52,7 +53,7 @@ g!brand (\ ! map (|>> %.code code.text) (meta.gensym (format (%.name [this-module name])))) #let [capability (` (..Capability (.primitive (~ g!brand)) (~ input) (~ output)))]] - (wrap (list (` (type: (~+ (writer.export export)) + (wrap (list (` (type: (~+ (|export|.write export)) (~ (writer.declaration declaration)) (~ capability))) (` (def: (~ (code.local-identifier forge)) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 8495b14e1..a8fca807a 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -106,7 +106,7 @@ (def: #export (mod modular) (All [m] (Format (modular.Mod m))) - (let [[_ modulus] (modular.un-mod modular)] + (let [[modulus _] (modular.un-modular modular)] (\ (modular.codec modulus) encode modular))) (def: #export (list formatter) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index 0b4964897..84d4e8873 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -21,15 +21,16 @@ [syntax (#+ syntax:) [common ["csr" reader] - ["csw" writer]]]] + ["csw" writer] + ["|.|" export]]]] ["." type]]) -(syntax: #export (poly: {export csr.export} +(syntax: #export (poly: {export |export|.parser} {name s.local-identifier} body) (with-gensyms [g!_ g!type g!output] (let [g!name (code.identifier ["" name])] - (wrap (.list (` ((~! syntax:) (~+ (csw.export export)) ((~ g!name) {(~ g!type) (~! s.identifier)}) + (wrap (.list (` ((~! syntax:) (~+ (|export|.write export)) ((~ g!name) {(~ g!type) (~! s.identifier)}) ((~! do) (~! meta.monad) [(~ g!type) ((~! meta.find-type-def) (~ g!type))] (case (: (.Either .Text .Code) @@ -53,7 +54,7 @@ (#.Some (list\fold (text.replace-once "?") poly args)) #.None)) -(syntax: #export (derived: {export csr.export} +(syntax: #export (derived: {export |export|.parser} {?name (p.maybe s.local-identifier)} {[poly-func poly-args] (s.form (p.and s.identifier (p.many s.identifier)))} {?custom-impl (p.maybe s.any)}) @@ -76,7 +77,7 @@ #.None (` ((~ (code.identifier poly-func)) (~+ (list\map code.identifier poly-args)))))]] - (wrap (.list (` (def: (~+ (csw.export export)) + (wrap (.list (` (def: (~+ (|export|.write export)) (~ (code.identifier ["" name])) {#.struct? #1} (~ impl))))))) diff --git a/stdlib/source/lux/macro/syntax/common/export.lux b/stdlib/source/lux/macro/syntax/common/export.lux new file mode 100644 index 000000000..e89f908e4 --- /dev/null +++ b/stdlib/source/lux/macro/syntax/common/export.lux @@ -0,0 +1,20 @@ +(.module: + [lux #* + [control + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]]]) + +(def: token + (' #export)) + +(def: #export (write exported?) + (-> Bit (List Code)) + (if exported? + (list ..token) + (list))) + +(def: #export parser + (Parser Bit) + (<>.either (<>.after (<code>.this! ..token) + (<>\wrap true)) + (<>\wrap false))) diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux index 7033069f6..689e166d0 100644 --- a/stdlib/source/lux/macro/syntax/common/reader.lux +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -14,11 +14,6 @@ ["." meta]] ["." //]) -(def: #export export - (Parser Bit) - (p.either (p.after (s.tag! (name-of #export)) (p\wrap #1)) - (p\wrap #0))) - (def: #export declaration {#.doc (doc "A reader for declaration syntax." "Such as:" diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux index 18abab65a..8c77cffbc 100644 --- a/stdlib/source/lux/macro/syntax/common/writer.lux +++ b/stdlib/source/lux/macro/syntax/common/writer.lux @@ -11,12 +11,6 @@ ["." code]]] ["." //]) -(def: #export (export exported?) - (-> Bit (List Code)) - (if exported? - (list (' #export)) - (list))) - (def: #export (declaration declaration) (-> //.Declaration Code) (` ((~ (code.local-identifier (get@ #//.declaration-name declaration))) diff --git a/stdlib/source/lux/math/modular.lux b/stdlib/source/lux/math/modular.lux index 445789bde..71e3a57a1 100644 --- a/stdlib/source/lux/math/modular.lux +++ b/stdlib/source/lux/math/modular.lux @@ -1,14 +1,16 @@ (.module: [lux #* [abstract + [equivalence (#+ Equivalence)] + [order (#+ Order)] [codec (#+ Codec)] [monad (#+ do)]] [control ["." try (#+ Try)] - ["ex" exception (#+ exception:)] - ["p" parser - ["l" text (#+ Parser)] - ["s" code]]] + ["." exception (#+ exception:)] + ["<>" parser + ["<.>" text (#+ Parser)] + ["<.>" code]]] [data [number ["i" int ("#\." decimal)]] @@ -17,108 +19,78 @@ abstract] [macro ["." code] - [syntax (#+ syntax:)]]]) - -(exception: #export zero-cannot-be-a-modulus) - -(abstract: #export (Modulus m) - Int - - {#.doc (doc "A number used as a modulus in modular arithmetic." - "It cannot be 0.")} - - (def: #export (from-int value) - (Ex [m] (-> Int (Try (Modulus m)))) - (if (i.= +0 value) - (ex.throw zero-cannot-be-a-modulus []) - (#try.Success (:abstraction value)))) - - (def: #export (to-int modulus) - (All [m] (-> (Modulus m) Int)) - (|> modulus :representation)) - ) - -(exception: #export [m] (incorrect-modulus {modulus (Modulus m)} - {parsed Int}) - (ex.report ["Expected" (i\encode (to-int modulus))] - ["Actual" (i\encode parsed)])) - -(exception: #export [rm sm] (cannot-equalize-moduli {reference (Modulus rm)} - {sample (Modulus sm)}) - (ex.report ["Reference" (i\encode (to-int reference))] - ["Sample" (i\encode (to-int sample))])) - -(def: #export (congruent? modulus reference sample) - (All [m] (-> (Modulus m) Int Int Bit)) - (|> sample - (i.- reference) - (i.% (to-int modulus)) - (i.= +0))) - -(syntax: #export (modulus {modulus s.int}) - (case (from-int modulus) - (#try.Success _) - (wrap (list (` (try.assume (..from-int (~ (code.int modulus))))))) - - (#try.Failure error) - (p.fail error))) - -(def: intL - (Parser Int) - (p.codec i.decimal - (l.and (l.one-of "-+") (l.many l.decimal)))) + [syntax (#+ syntax:)]]] + [// + ["/" modulus (#+ Modulus)]]) (abstract: #export (Mod m) - {#remainder Int - #modulus (Modulus m)} + {#modulus (Modulus m) + #remainder Int} {#.doc "A number under a modulus."} - (def: #export (mod modulus) - (All [m] (-> (Modulus m) (-> Int (Mod m)))) - (function (_ value) - (:abstraction {#remainder (i.mod (to-int modulus) value) - #modulus modulus}))) + (def: #export (modular modulus value) + (All [m] (-> (Modulus m) Int (Mod m))) + (:abstraction {#modulus modulus + #remainder (i.mod (/.divisor modulus) value)})) - (def: #export (un-mod modular) - (All [m] (-> (Mod m) [Int (Modulus m)])) - (:representation modular)) + (def: #export un-modular + (All [m] (-> (Mod m) [(Modulus m) Int])) + (|>> :representation)) - (def: separator " mod ") + (exception: #export [m] (incorrect-modulus {modulus (Modulus m)} + {parsed Int}) + (exception.report + ["Expected" (i\encode (/.divisor modulus))] + ["Actual" (i\encode parsed)])) - (structure: #export (codec modulus) + (def: separator + " mod ") + + (def: intL + (Parser Int) + (<>.codec i.decimal + (<text>.and (<text>.one-of "-+") (<text>.many <text>.decimal)))) + + (structure: #export (codec expected) (All [m] (-> (Modulus m) (Codec Text (Mod m)))) (def: (encode modular) - (let [[remainder modulus] (:representation modular)] + (let [[_ remainder] (:representation modular)] ($_ text\compose (i\encode remainder) - separator - (i\encode (to-int modulus))))) + ..separator + (i\encode (/.divisor expected))))) (def: decode - (l.run (do p.monad - [[remainder _ _modulus] ($_ p.and intL (l.this separator) intL) - _ (p.assert (ex.construct incorrect-modulus [modulus _modulus]) - (i.= (to-int modulus) _modulus))] - (wrap (mod modulus remainder)))))) - - (def: #export (equalize reference sample) + (<text>.run (do <>.monad + [[remainder _ actual] ($_ <>.and intL (<text>.this ..separator) intL) + _ (<>.assert (exception.construct ..incorrect-modulus [expected actual]) + (i.= (/.divisor expected) actual))] + (wrap (..modular expected remainder)))))) + + (exception: #export [rm sm] (unequal-moduli {reference (Modulus rm)} + {subject (Modulus sm)}) + (exception.report + ["Reference" (i\encode (/.divisor reference))] + ["Subject" (i\encode (/.divisor subject))])) + + (def: #export (equalize reference subject) (All [r s] (-> (Mod r) (Mod s) (Try (Mod r)))) - (let [[reference reference-modulus] (:representation reference) - [sample sample-modulus] (:representation sample)] - (if (i.= (to-int reference-modulus) - (to-int sample-modulus)) - (#try.Success (:abstraction {#remainder sample - #modulus reference-modulus})) - (ex.throw cannot-equalize-moduli [reference-modulus sample-modulus])))) + (let [[reference-modulus reference] (:representation reference) + [subject-modulus subject] (:representation subject)] + (if (i.= (/.divisor reference-modulus) + (/.divisor subject-modulus)) + (#try.Success (:abstraction {#modulus reference-modulus + #remainder subject})) + (exception.throw ..unequal-moduli [reference-modulus subject-modulus])))) (template [<name> <op>] - [(def: #export (<name> reference sample) + [(def: #export (<name> reference subject) (All [m] (-> (Mod m) (Mod m) Bit)) - (let [[reference _] (:representation reference) - [sample _] (:representation sample)] - (<op> reference sample)))] + (let [[_ reference] (:representation reference) + [_ subject] (:representation subject)] + (<op> reference subject)))] [= i.=] [< i.<] @@ -127,15 +99,26 @@ [>= i.>=] ) + (structure: #export equivalence + (All [%] (Equivalence (Mod %))) + + (def: = ..=)) + + (structure: #export order + (All [%] (Order (Mod %))) + + (def: &equivalence ..equivalence) + (def: < ..<)) + (template [<name> <op>] [(def: #export (<name> param subject) (All [m] (-> (Mod m) (Mod m) (Mod m))) - (let [[param modulus] (:representation param) - [subject _] (:representation subject)] - (:abstraction {#remainder (|> subject + (let [[modulus param] (:representation param) + [_ subject] (:representation subject)] + (:abstraction {#modulus modulus + #remainder (|> subject (<op> param) - (i.mod (to-int modulus))) - #modulus modulus})))] + (i.mod (/.divisor modulus)))})))] [+ i.+] [- i.-] @@ -146,7 +129,7 @@ (-> Int Int [Int Int Int]) (if (i.= +0 a) [+0 +1 b] - (let [[ak bk gcd] (gcd+ (i.% a b) a)] + (let [[ak bk gcd] (gcd+ (i.mod a b) a)] [(i.- (i.* ak (i./ a b)) bk) @@ -155,11 +138,10 @@ (def: #export (inverse modular) (All [m] (-> (Mod m) (Maybe (Mod m)))) - (let [[value modulus] (:representation modular) - _modulus (to-int modulus) - [vk mk gcd] (gcd+ value _modulus) + (let [[modulus value] (:representation modular) + [vk mk gcd] (gcd+ value (/.divisor modulus)) co-prime? (i.= +1 gcd)] (if co-prime? - (#.Some (mod modulus vk)) + (#.Some (..modular modulus vk)) #.None))) ) diff --git a/stdlib/source/lux/math/modulus.lux b/stdlib/source/lux/math/modulus.lux new file mode 100644 index 000000000..d3bb9f6f6 --- /dev/null +++ b/stdlib/source/lux/math/modulus.lux @@ -0,0 +1,55 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + ["." exception (#+ exception:)] + [parser + ["<.>" code]]] + [data + [number + ["i" int]]] + [type + abstract] + ["." meta] + [macro + [syntax (#+ syntax:)] + ["." code]]]) + +(exception: #export zero-cannot-be-a-modulus) + +(abstract: #export (Modulus m) + Int + + {#.doc (doc "A number used as a modulus in modular arithmetic." + "It cannot be 0.")} + + (def: #export (modulus value) + (Ex [m] (-> Int (Try (Modulus m)))) + (if (i.= +0 value) + (exception.throw ..zero-cannot-be-a-modulus []) + (#try.Success (:abstraction value)))) + + (def: #export divisor + (All [m] (-> (Modulus m) Int)) + (|>> :representation)) + + (def: #export (= reference subject) + (All [r s] (-> (Modulus r) (Modulus s) Bit)) + (i.= (:representation reference) + (:representation subject))) + + (def: #export (congruent? modulus reference subject) + (All [m] (-> (Modulus m) Int Int Bit)) + (|> subject + (i.- reference) + (i.% (:representation modulus)) + (i.= +0))) + ) + +(syntax: #export (literal {divisor <code>.int}) + (meta.lift + (do try.monad + [_ (..modulus divisor)] + (wrap (list (` ((~! try.assume) (..modulus (~ (code.int divisor)))))))))) diff --git a/stdlib/source/lux/meta.lux b/stdlib/source/lux/meta.lux index 82fa1e10f..8becc186c 100644 --- a/stdlib/source/lux/meta.lux +++ b/stdlib/source/lux/meta.lux @@ -142,8 +142,7 @@ (#try.Success [compiler current-module]) _ - (#try.Failure "No current module.") - ))) + (#try.Failure "No current module.")))) (def: #export current-module (Meta Module) @@ -160,6 +159,19 @@ _ false)) +(def: #export (normalize name) + {#.doc (doc "If given a name without a module prefix, gives it the current module's name as prefix." + "Otherwise, returns the name as-is.")} + (-> Name (Meta Name)) + (case name + ["" name] + (do ..monad + [module-name current-module-name] + (wrap [module-name name])) + + _ + (\ ..monad wrap name))) + (def: (find-macro' modules this-module module name) (-> (List [Text Module]) Text Text Text (Maybe Macro)) @@ -178,27 +190,19 @@ (#.Some (:coerce Macro def-value)) #.None)))) -(def: #export (normalize name) - {#.doc (doc "If given a name without a module prefix, gives it the current module's name as prefix." - "Otherwise, returns the name as-is.")} - (-> Name (Meta Name)) - (case name - ["" name] - (do ..monad - [module-name current-module-name] - (wrap [module-name name])) - - _ - (\ ..monad wrap name))) - (def: #export (find-macro full-name) (-> Name (Meta (Maybe Macro))) (do ..monad - [[module name] (normalize full-name) - this-module current-module-name] + [[module name] (normalize full-name)] (: (Meta (Maybe Macro)) (function (_ compiler) - (#try.Success [compiler (find-macro' (get@ #.modules compiler) this-module module name)]))))) + (let [macro (case (..current-module-name compiler) + (#try.Failure error) + #.None + + (#try.Success [_ this-module]) + (find-macro' (get@ #.modules compiler) this-module module name))] + (#try.Success [compiler macro])))))) (def: #export (expand-once syntax) {#.doc (doc "Given code that requires applying a macro, does it once and returns the result." @@ -701,3 +705,12 @@ [log-expand-all! expand-all] [log-expand-once! expand-once] ) + +(def: #export (lift result) + (All [a] (-> (Try a) (Meta a))) + (case result + (#try.Success output) + (\ ..monad wrap output) + + (#try.Failure error) + (..fail error))) diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux index 95855c5df..604984c10 100644 --- a/stdlib/source/lux/type/abstract.lux +++ b/stdlib/source/lux/type/abstract.lux @@ -17,7 +17,8 @@ [syntax (#+ syntax:) ["cs" common ["csr" reader] - ["csw" writer]]]] + ["csw" writer] + ["|.|" export]]]] [type (#+ :cast)]]) (type: Stack List) @@ -206,7 +207,7 @@ ## TODO: Make sure the generated code always gets optimized away. ## (This applies to uses of ":abstraction" and ":representation") (syntax: #export (abstract: - {export csr.export} + {export |export|.parser} {[name type-vars] declaration} representation-type {annotations (<>.default cs.empty-annotations csr.annotations)} @@ -221,7 +222,7 @@ type-varsC abstraction-declaration representation-declaration])] - (wrap (list& (` (type: (~+ (csw.export export)) (~ abstraction-declaration) + (wrap (list& (` (type: (~+ (|export|.write export)) (~ abstraction-declaration) (~ (csw.annotations annotations)) (primitive (~ (code.text (abstraction-type-name [current-module name]))) [(~+ type-varsC)]))) diff --git a/stdlib/source/lux/type/unit.lux b/stdlib/source/lux/type/unit.lux index deffa4e83..9f5fdba78 100644 --- a/stdlib/source/lux/type/unit.lux +++ b/stdlib/source/lux/type/unit.lux @@ -20,7 +20,8 @@ [syntax (#+ syntax:) ["cs" common ["csr" reader] - ["csw" writer]]]] + ["csw" writer] + ["|.|" export]]]] [type abstract]]) @@ -70,13 +71,13 @@ ) (syntax: #export (unit: - {export csr.export} + {export |export|.parser} {name s.local-identifier} {annotations (p.default cs.empty-annotations csr.annotations)}) - (wrap (list (` (type: (~+ (csw.export export)) (~ (code.local-identifier name)) + (wrap (list (` (type: (~+ (|export|.write export)) (~ (code.local-identifier name)) (~ (csw.annotations annotations)) (primitive (~ (code.text (unit-name name)))))) - (` (def: (~+ (csw.export export)) (~ (code.local-identifier (format "@" name))) + (` (def: (~+ (|export|.write export)) (~ (code.local-identifier (format "@" name))) (~ (code.local-identifier name)) (:assume []))) ))) @@ -93,15 +94,15 @@ (wrap [(.nat numerator) (.nat denominator)])))) (syntax: #export (scale: - {export csr.export} + {export |export|.parser} {name s.local-identifier} {(^slots [#ratio.numerator #ratio.denominator]) ratio^} {annotations (p.default cs.empty-annotations csr.annotations)}) (let [g!scale (code.local-identifier name)] - (wrap (list (` (type: (~+ (csw.export export)) ((~ g!scale) (~' u)) + (wrap (list (` (type: (~+ (|export|.write export)) ((~ g!scale) (~' u)) (~ (csw.annotations annotations)) (primitive (~ (code.text (scale-name name))) [(~' u)]))) - (` (structure: (~+ (csw.export export)) (~ (code.local-identifier (format "@" name))) + (` (structure: (~+ (|export|.write export)) (~ (code.local-identifier (format "@" name))) (..Scale (~ g!scale)) (def: (~' scale) (|>> ..out diff --git a/stdlib/source/program/aedifex.lux b/stdlib/source/program/aedifex.lux index cfa106407..4e78183f1 100644 --- a/stdlib/source/program/aedifex.lux +++ b/stdlib/source/program/aedifex.lux @@ -63,7 +63,7 @@ (-> /.Profile (List (Repository Promise))) (|>> (get@ #/.repositories) set.to-list - (list\map (|>> /repository.remote /repository.async)))) + (list\map (|>> (/repository.remote #.None) /repository.async)))) (def: (with-dependencies program console command profile) (All [a] @@ -149,9 +149,8 @@ (dictionary.get repository (get@ #/.deploy-repositories profile))] [(#.Some artifact) (#.Some repository)] (/command/deploy.do! console - (/repository.async (/repository.remote repository)) + (/repository.async (/repository.remote (#.Some identity) repository)) (file.async file.default) - identity artifact profile) diff --git a/stdlib/source/program/aedifex/cache.lux b/stdlib/source/program/aedifex/cache.lux index 50062c3f7..ce95f65b7 100644 --- a/stdlib/source/program/aedifex/cache.lux +++ b/stdlib/source/program/aedifex/cache.lux @@ -26,12 +26,14 @@ ["." file (#+ Path File Directory)]]] ["." // #_ ["#" local] - ["#." hash] + ["#." hash (#+ Hash SHA-1 MD5)] ["#." package (#+ Package)] ["#." artifact (#+ Artifact) - ["#/." extension]] - [dependency (#+ Dependency) - [resolution (#+ Resolution)]]]) + ["#/." type] + ["#/." extension (#+ Extension)]] + ["#." dependency (#+ Dependency) + [resolution (#+ Resolution)] + ["#/." status (#+ Status)]]]) (def: (write! system content file) (-> (file.System Promise) Binary Path (Promise (Try Any))) @@ -40,6 +42,36 @@ (file.get-file promise.monad system file))] (!.use (\ file over-write) [content]))) +(def: (write-hashed system directory [artifact type] [data status]) + (-> (file.System Promise) Path Dependency [Binary Status] (Promise (Try Any))) + (let [prefix (format directory + (\ system separator) + (//artifact.identity artifact) + (//artifact/extension.extension type))] + (do {! (try.with promise.monad)} + [_ (..write! system data prefix) + #let [write-hash (: (All [h] (-> (Codec Text (Hash h)) Extension (Hash h) (Promise (Try Any)))) + (function (_ codec extension hash) + (..write! system + (|> hash (\ codec encode) (\ encoding.utf8 encode)) + (format prefix extension))))]] + (case status + #//dependency/status.Unverified + (wrap []) + + (#//dependency/status.Partial partial) + (case partial + (#.Left sha-1) + (write-hash //hash.sha-1-codec //artifact/extension.sha-1 sha-1) + + (#.Right md5) + (write-hash //hash.md5-codec //artifact/extension.md5 md5)) + + (#//dependency/status.Verified sha-1 md5) + (do ! + [_ (write-hash //hash.sha-1-codec //artifact/extension.sha-1 sha-1)] + (write-hash //hash.md5-codec //artifact/extension.md5 md5)))))) + (def: #export (write-one program system [artifact type] package) (-> (Program Promise) (file.System Promise) Dependency Package (Promise (Try Artifact))) (do promise.monad @@ -47,27 +79,12 @@ (do (try.with promise.monad) [directory (: (Promise (Try Path)) (file.make-directories promise.monad system (//.path system home artifact))) - #let [prefix (format directory (\ system separator) (//artifact.identity artifact))] - directory (: (Promise (Try (Directory Promise))) - (file.get-directory promise.monad system directory)) - _ (..write! system - (get@ #//package.library package) - (format prefix (//artifact/extension.extension type))) - _ (..write! system - (|> package - (get@ #//package.sha-1) - (\ //hash.sha-1-codec encode) - (\ encoding.utf8 encode)) - (format prefix //artifact/extension.sha-1)) - _ (..write! system - (|> package - (get@ #//package.md5) - (\ //hash.md5-codec encode) - (\ encoding.utf8 encode)) - (format prefix //artifact/extension.md5)) - _ (..write! system - (|> package (get@ #//package.pom) (\ xml.codec encode) (\ encoding.utf8 encode)) - (format prefix //artifact/extension.pom))] + _ (write-hashed system directory [artifact type] (get@ #//package.library package)) + _ (let [[pom status] (get@ #//package.pom package)] + (write-hashed system directory + [artifact //artifact/type.pom] + [(|> pom (\ xml.codec encode) (\ encoding.utf8 encode)) + status]))] (wrap artifact)))) (def: #export (write-all program system resolution) @@ -104,19 +121,18 @@ (//artifact.identity artifact))]] (do (try.with promise.monad) [pom (..read! system (format prefix //artifact/extension.pom)) - library (..read! system (format prefix (//artifact/extension.extension type))) - sha-1 (..read! system (format prefix //artifact/extension.sha-1)) - md5 (..read! system (format prefix //artifact/extension.md5))] + #let [extension (//artifact/extension.extension type)] + library (..read! system (format prefix extension)) + library-sha-1 (..read! system (format prefix extension //artifact/extension.sha-1)) + library-md5 (..read! system (format prefix extension //artifact/extension.md5))] (\ promise.monad wrap (do try.monad [pom (..decode xml.codec pom) - sha-1 (..decode //hash.sha-1-codec sha-1) - md5 (..decode //hash.md5-codec md5)] + library-sha-1 (..decode //hash.sha-1-codec library-sha-1) + library-md5 (..decode //hash.md5-codec library-md5)] (wrap {#//package.origin #//package.Local - #//package.library library - #//package.pom pom - #//package.sha-1 sha-1 - #//package.md5 md5})))))) + #//package.library [library (#//dependency/status.Verified library-sha-1 library-md5)] + #//package.pom [pom #//dependency/status.Unverified]})))))) (def: #export (read-all program system dependencies resolution) (-> (Program Promise) (file.System Promise) (List Dependency) Resolution (Promise (Try Resolution))) diff --git a/stdlib/source/program/aedifex/cli.lux b/stdlib/source/program/aedifex/cli.lux index c00f62852..4625136a3 100644 --- a/stdlib/source/program/aedifex/cli.lux +++ b/stdlib/source/program/aedifex/cli.lux @@ -10,7 +10,8 @@ ["." product] ["." text]]] [// - [repository (#+ Identity)] + [repository + [identity (#+ Identity)]] ["/" profile (#+ Name)]]) (type: #export Compilation diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux index 4e33b145a..5763c1ff5 100644 --- a/stdlib/source/program/aedifex/command/deploy.lux +++ b/stdlib/source/program/aedifex/command/deploy.lux @@ -36,7 +36,8 @@ ["#." action (#+ Action)] ["#." pom] ["#." hash] - ["#." repository (#+ Identity Repository)] + ["#." repository (#+ Repository) + [identity (#+ Identity)]] ["#." metadata ["#/." artifact] ["#/." snapshot]] @@ -89,11 +90,11 @@ (format ///artifact/type.lux-library ///artifact/extension.sha-1) (format ///artifact/type.lux-library ///artifact/extension.md5))) -(def: #export (do! console repository fs identity artifact profile) - (-> (Console Promise) (Repository Promise) (file.System Promise) Identity Artifact (Command Any)) +(def: #export (do! console repository fs artifact profile) + (-> (Console Promise) (Repository Promise) (file.System Promise) Artifact (Command Any)) (let [deploy! (: (-> Extension Binary (Action Any)) (|>> (///repository.uri artifact) - (\ repository upload identity))) + (\ repository upload))) fully-deploy! (: (-> Extension Binary (Action Any)) (function (_ extension payload) (do ///action.monad @@ -126,12 +127,12 @@ ///metadata/snapshot.write (\ xml.codec encode) (\ encoding.utf8 encode) - (\ repository upload identity (///metadata.version artifact))) + (\ repository upload (///metadata.version artifact))) _ (|> project (set@ #///metadata/artifact.versions (list version)) (set@ #///metadata/artifact.last-updated now) ///metadata/artifact.write (\ xml.codec encode) (\ encoding.utf8 encode) - (\ repository upload identity (///metadata.project artifact)))] + (\ repository upload (///metadata.project artifact)))] (console.write-line //clean.success console))))) diff --git a/stdlib/source/program/aedifex/dependency/resolution.lux b/stdlib/source/program/aedifex/dependency/resolution.lux index 2131495b9..f49d1da56 100644 --- a/stdlib/source/program/aedifex/dependency/resolution.lux +++ b/stdlib/source/program/aedifex/dependency/resolution.lux @@ -31,65 +31,70 @@ [net (#+ URL) ["." uri]]]] ["." // (#+ Dependency) + ["#." status (#+ Status)] ["/#" // #_ ["/" profile] ["#." repository (#+ Address Repository)] - ["#." hash] + ["#." hash (#+ Hash SHA-1 MD5)] ["#." pom] ["#." package (#+ Package)] ["#." artifact (#+ Artifact) ["#/." extension (#+ Extension)]]]]) (template [<name>] - [(exception: #export (<name> {dependency Dependency} {hash Text}) + [(exception: #export (<name> {artifact Artifact} {extension Extension} {hash Text}) (exception.report - ["Artifact" (///artifact.format (get@ #//.artifact dependency))] - ["Type" (%.text (get@ #//.type dependency))] + ["Artifact" (///artifact.format artifact)] + ["Extension" (%.text extension)] ["Hash" (%.text hash)]))] [sha-1-does-not-match] [md5-does-not-match] ) -(def: (verified-hash dependency library repository artifact extension hash codec exception) +(def: (verified-hash library repository artifact extension hash codec exception) (All [h] - (-> Dependency Binary (Repository Promise) Artifact Extension - (-> Binary (///hash.Hash h)) (Codec Text (///hash.Hash h)) - (Exception [Dependency Text]) - (Promise (Try (///hash.Hash h))))) + (-> Binary (Repository Promise) Artifact Extension + (-> Binary (Hash h)) (Codec Text (Hash h)) + (Exception [Artifact Extension Text]) + (Promise (Try (Hash h))))) (do (try.with promise.monad) [actual (\ repository download (///repository.uri artifact extension))] (\ promise.monad wrap (do try.monad [output (\ encoding.utf8 decode actual) actual (\ codec decode output) - _ (exception.assert exception [dependency output] + _ (exception.assert exception [artifact extension output] (\ ///hash.equivalence = (hash library) actual))] (wrap actual))))) +(def: (hashed repository artifact extension) + (-> (Repository Promise) Artifact Extension (Promise (Try [Binary Status]))) + (do (try.with promise.monad) + [data (\ repository download (///repository.uri artifact extension)) + sha-1 (..verified-hash data + repository 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) + ///hash.md5 ///hash.md5-codec ..md5-does-not-match)] + (wrap [data (#//status.Verified sha-1 md5)]))) + (def: #export (one repository dependency) (-> (Repository Promise) Dependency (Promise (Try Package))) (let [[artifact type] dependency extension (///artifact/extension.extension type)] (do (try.with promise.monad) - [library (\ repository download (///repository.uri artifact extension)) - sha-1 (..verified-hash dependency library - repository artifact ///artifact/extension.sha-1 - ///hash.sha-1 ///hash.sha-1-codec ..sha-1-does-not-match) - md5 (..verified-hash dependency library - repository artifact ///artifact/extension.md5 - ///hash.md5 ///hash.md5-codec ..md5-does-not-match) - pom (\ repository download (///repository.uri artifact ///artifact/extension.pom))] + [[pom pom-status] (..hashed repository artifact ///artifact/extension.pom) + library-&-status (..hashed repository artifact extension)] (\ promise.monad wrap (do try.monad [pom (\ encoding.utf8 decode pom) pom (\ xml.codec decode pom) profile (<xml>.run ///pom.parser pom)] (wrap {#///package.origin #///package.Remote - #///package.library library - #///package.pom pom - #///package.sha-1 sha-1 - #///package.md5 md5})))))) + #///package.library library-&-status + #///package.pom [pom pom-status]})))))) (type: #export Resolution (Dictionary Dependency Package)) diff --git a/stdlib/source/program/aedifex/package.lux b/stdlib/source/program/aedifex/package.lux index de831555e..03f2c3994 100644 --- a/stdlib/source/program/aedifex/package.lux +++ b/stdlib/source/program/aedifex/package.lux @@ -15,7 +15,8 @@ [collection [set (#+ Set)]]]] ["." // #_ - [dependency (#+ Dependency)] + [dependency (#+ Dependency) + ["#." status (#+ Status)]] ["/" profile] ["#." hash (#+ Hash SHA-1 MD5)] ["#." pom]]) @@ -34,14 +35,13 @@ (Equivalence Origin) ($_ sum.equivalence ..any-equivalence - ..any-equivalence)) + ..any-equivalence + )) (type: #export Package {#origin Origin - #library Binary - #pom XML - #sha-1 (Hash SHA-1) - #md5 (Hash MD5)}) + #library [Binary Status] + #pom [XML Status]}) (template [<name> <tag>] [(def: #export <name> @@ -55,14 +55,13 @@ (def: #export (local pom library) (-> XML Binary Package) {#origin #Local - #library library - #pom pom - #sha-1 (//hash.sha-1 library) - #md5 (//hash.md5 library)}) + #library [library #//status.Unverified] + #pom [pom #//status.Unverified]}) (def: #export dependencies (-> Package (Try (Set Dependency))) (|>> (get@ #pom) + product.left (<xml>.run //pom.parser) (try\map (get@ #/.dependencies)))) @@ -70,8 +69,6 @@ (Equivalence Package) ($_ product.equivalence ..origin-equivalence - binary.equivalence - xml.equivalence - //hash.equivalence - //hash.equivalence + (product.equivalence binary.equivalence //status.equivalence) + (product.equivalence xml.equivalence //status.equivalence) )) diff --git a/stdlib/source/program/aedifex/repository.lux b/stdlib/source/program/aedifex/repository.lux index c351e9d0c..351d1c066 100644 --- a/stdlib/source/program/aedifex/repository.lux +++ b/stdlib/source/program/aedifex/repository.lux @@ -13,8 +13,7 @@ [data ["." binary (#+ Binary)] ["." text - ["%" format (#+ format)] - ["." encoding]] + ["%" format (#+ format)]] [number ["n" nat]]] [tool @@ -26,27 +25,19 @@ [world [net (#+ URL) ["." uri (#+ URI)]]]] - ["." // #_ - ["#." artifact (#+ Artifact) - ["#/." extension (#+ Extension)]]]) + ["." / #_ + ["#." identity (#+ Identity)] + ["/#" // #_ + ["#." artifact (#+ Artifact) + ["#/." extension (#+ Extension)]]]]) (type: #export Address URL) -(type: #export User - Text) - -(type: #export Password - Text) - -(type: #export Identity - {#user User - #password Password}) - (signature: #export (Repository !) (: (-> URI (! (Try Binary))) download) - (: (-> Identity URI Binary (! (Try Any))) + (: (-> URI Binary (! (Try Any))) upload)) (def: #export (async repository) @@ -55,14 +46,14 @@ (def: (download uri) (promise.future (\ repository download uri))) - (def: (upload identity uri content) - (promise.future (\ repository upload identity uri content))) + (def: (upload uri content) + (promise.future (\ repository upload uri content))) )) (signature: #export (Simulation s) (: (-> URI s (Try [s Binary])) on-download) - (: (-> Identity URI Binary s (Try s)) + (: (-> URI Binary s (Try s)) on-upload)) (def: #export (mock simulation init) @@ -82,11 +73,11 @@ (#try.Failure error) (wrap (#try.Failure error)))))) - (def: (upload identity uri content) + (def: (upload uri content) (stm.commit (do {! stm.monad} [|state| (stm.read state)] - (case (\ simulation on-upload identity uri content |state|) + (case (\ simulation on-upload uri content |state|) (#try.Success |state|) (do ! [_ (stm.write |state| state)] @@ -126,28 +117,19 @@ (new [java/lang/String]) (openConnection [] #io #try java/net/URLConnection)]) -(import: java/util/Base64$Encoder - ["#::." - (encodeToString [[byte]] java/lang/String)]) - -(import: java/util/Base64 - ["#::." - (#static getEncoder [] java/util/Base64$Encoder)]) - (import: java/io/BufferedInputStream ["#::." (new [java/io/InputStream]) (read [[byte] int int] #io #try int)]) +(exception: #export (no-credentials {address Address}) + (exception.report + ["Address" (%.text address)])) + (exception: #export (deployment-failure {code Int}) (exception.report ["Code" (%.int code)])) -(def: (basic-auth user password) - (-> User Password Text) - (format "Basic " (java/util/Base64$Encoder::encodeToString (\ encoding.utf8 encode (format user ":" password)) - (java/util/Base64::getEncoder)))) - (def: #export (uri artifact extension) (-> Artifact Extension URI) (format (//artifact.uri artifact) extension)) @@ -158,8 +140,8 @@ (def: user-agent (format "LuxAedifex/" (version.format language/lux.version))) -(structure: #export (remote address) - (All [s] (-> Address (Repository IO))) +(structure: #export (remote identity address) + (All [s] (-> (Maybe Identity) Address (Repository IO))) (def: (download uri) (do {! (try.with io.monad)} @@ -186,21 +168,26 @@ [chunk (\ io.monad wrap (binary.slice 0 (.nat bytes-read) buffer))] (recur (\ binary.monoid compose output chunk))))))))) - (def: (upload [user password] uri content) - (do (try.with io.monad) - [connection (|> (format address uri) - java/net/URL::new - java/net/URL::openConnection) - #let [connection (:coerce java/net/HttpURLConnection connection)] - _ (java/net/HttpURLConnection::setRequestMethod "PUT" connection) - _ (java/net/URLConnection::setDoOutput true connection) - _ (java/net/URLConnection::setRequestProperty "Authorization" (..basic-auth user password) connection) - stream (java/net/URLConnection::getOutputStream connection) - _ (java/io/OutputStream::write content stream) - _ (java/io/OutputStream::flush stream) - _ (java/lang/AutoCloseable::close stream) - code (java/net/HttpURLConnection::getResponseCode connection)] - (case code - +201 (wrap []) - _ (\ io.monad wrap (exception.throw ..deployment-failure [code]))))) + (def: (upload uri content) + (case identity + #.None + (\ io.monad wrap (exception.throw ..no-credentials [address])) + + (#.Some [user password]) + (do (try.with io.monad) + [connection (|> (format address uri) + java/net/URL::new + java/net/URL::openConnection) + #let [connection (:coerce java/net/HttpURLConnection connection)] + _ (java/net/HttpURLConnection::setRequestMethod "PUT" connection) + _ (java/net/URLConnection::setDoOutput true connection) + _ (java/net/URLConnection::setRequestProperty "Authorization" (/identity.basic-auth user password) connection) + stream (java/net/URLConnection::getOutputStream connection) + _ (java/io/OutputStream::write content stream) + _ (java/io/OutputStream::flush stream) + _ (java/lang/AutoCloseable::close stream) + code (java/net/HttpURLConnection::getResponseCode connection)] + (case code + +201 (wrap []) + _ (\ io.monad wrap (exception.throw ..deployment-failure [code])))))) ) diff --git a/stdlib/source/program/aedifex/repository/identity.lux b/stdlib/source/program/aedifex/repository/identity.lux new file mode 100644 index 000000000..fbc93f367 --- /dev/null +++ b/stdlib/source/program/aedifex/repository/identity.lux @@ -0,0 +1,42 @@ +(.module: + [lux #* + ["." host (#+ import:)] + [abstract + [equivalence (#+ Equivalence)]] + [data + ["." product] + ["." text + ["%" format (#+ format)] + ["." encoding]]]]) + +(type: #export User + Text) + +(type: #export Password + Text) + +(type: #export Identity + {#user User + #password Password}) + +(def: #export equivalence + (Equivalence Identity) + ($_ product.equivalence + text.equivalence + text.equivalence + )) + +(import: java/util/Base64$Encoder + ["#::." + (encodeToString [[byte]] java/lang/String)]) + +(import: java/util/Base64 + ["#::." + (#static getEncoder [] java/util/Base64$Encoder)]) + +(def: #export (basic-auth user password) + (-> User Password Text) + (let [credentials (\ encoding.utf8 encode (format user ":" password))] + (|> (java/util/Base64::getEncoder) + (java/util/Base64$Encoder::encodeToString credentials) + (format "Basic ")))) diff --git a/stdlib/source/spec/aedifex/repository.lux b/stdlib/source/spec/aedifex/repository.lux index acea123bc..0c492ea08 100644 --- a/stdlib/source/spec/aedifex/repository.lux +++ b/stdlib/source/spec/aedifex/repository.lux @@ -22,18 +22,18 @@ ["_." // #_ ["#." artifact]]}) -(def: #export (spec valid-identity valid-artifact invalid-identity invalid-artifact subject) - (-> /.Identity Artifact /.Identity Artifact (/.Repository Promise) Test) +(def: #export (spec valid-artifact invalid-artifact subject) + (-> Artifact Artifact (/.Repository Promise) Test) (do random.monad [expected (_binary.random 100)] (wrap ($_ _.and' (do promise.monad [#let [uri/good (/.uri valid-artifact //artifact/extension.lux-library)] - upload!/good (\ subject upload valid-identity uri/good expected) + upload!/good (\ subject upload uri/good expected) download!/good (\ subject download uri/good) #let [uri/bad (/.uri invalid-artifact //artifact/extension.lux-library)] - upload!/bad (\ subject upload invalid-identity uri/bad expected) + upload!/bad (\ subject upload uri/bad expected) download!/bad (\ subject download uri/bad)] (_.cover' [/.Repository] (and (case [upload!/good download!/good] diff --git a/stdlib/source/test/aedifex/cli.lux b/stdlib/source/test/aedifex/cli.lux index 9118132cd..b92ebe145 100644 --- a/stdlib/source/test/aedifex/cli.lux +++ b/stdlib/source/test/aedifex/cli.lux @@ -18,7 +18,6 @@ {#program ["." / ["/#" // #_ - [repository (#+ User Password)] ["#" profile]]]}) (def: compilation diff --git a/stdlib/source/test/aedifex/command/deploy.lux b/stdlib/source/test/aedifex/command/deploy.lux index 18045a20b..86f3e0dbb 100644 --- a/stdlib/source/test/aedifex/command/deploy.lux +++ b/stdlib/source/test/aedifex/command/deploy.lux @@ -48,7 +48,8 @@ ["#." pom] ["#." local] ["#." hash] - ["#." repository (#+ Identity Repository)] + ["#." repository (#+ Repository) + [identity (#+ Identity)]] ["#." artifact (#+ Artifact) ["#/." extension]]]]]}) @@ -69,9 +70,9 @@ (file.get-file promise.monad fs (format head (\ fs separator) head ".lux")))] (recur tail))))) -(def: (execute! program repository fs identity artifact profile) +(def: (execute! program repository fs artifact profile) (-> (Program Promise) (Repository Promise) (file.System Promise) - Identity Artifact ///.Profile + Artifact ///.Profile (Promise (Try Text))) (do promise.monad [home (\ program home [])] @@ -80,7 +81,7 @@ _ (..make-sources! fs (get@ #///.sources profile)) _ (: (Promise (Try Path)) (file.make-directories promise.monad fs (///local.repository fs home))) - _ (/.do! console repository fs identity artifact profile)] + _ (/.do! console repository fs artifact profile)] (!.use (\ console read-line) [])))) (def: #export test @@ -95,16 +96,15 @@ (wrap [artifact expected-pom profile]))) @profile.random) - identity @repository.identity home (random.ascii/alpha 5) working-directory (random.ascii/alpha 5) - #let [repository (///repository.mock (@repository.simulation identity) + #let [repository (///repository.mock @repository.simulation @repository.empty) fs (file.mock (\ file.default separator)) program (program.async (program.mock environment.empty home working-directory))]] (wrap (do {! promise.monad} [verdict (do {! ///action.monad} - [logging (..execute! program repository fs identity artifact profile) + [logging (..execute! program repository fs artifact profile) expected-library (|> profile (get@ #///.sources) set.to-list diff --git a/stdlib/source/test/aedifex/command/deps.lux b/stdlib/source/test/aedifex/command/deps.lux index 292185a28..84c51dc93 100644 --- a/stdlib/source/test/aedifex/command/deps.lux +++ b/stdlib/source/test/aedifex/command/deps.lux @@ -44,7 +44,8 @@ ["#." artifact ["#/." type]] ["#." dependency - ["#/." resolution]]]]]}) + ["#/." resolution] + ["#/." status]]]]]}) (def: #export test Test @@ -78,10 +79,10 @@ dependee-package (|> dependee-package (set@ #///package.origin #///package.Remote) - (set@ #///package.pom dependee-pom)) + (set@ #///package.pom [dependee-pom #///dependency/status.Unverified])) depender-package (|> depender-package (set@ #///package.origin #///package.Remote) - (set@ #///package.pom depender-pom)) + (set@ #///package.pom [depender-pom #///dependency/status.Unverified])) fs (file.mock (\ file.default separator)) program (program.async (program.mock environment.empty home working-directory))]] diff --git a/stdlib/source/test/aedifex/dependency/resolution.lux b/stdlib/source/test/aedifex/dependency/resolution.lux index c3e26f5bf..92ced9e74 100644 --- a/stdlib/source/test/aedifex/dependency/resolution.lux +++ b/stdlib/source/test/aedifex/dependency/resolution.lux @@ -15,7 +15,7 @@ [data ["." product] ["." binary] - ["." text ("#\." equivalence) + ["." text ["." encoding]] [format ["." xml]] @@ -39,7 +39,8 @@ ["#." package (#+ Package)] ["#." hash] ["#." repository (#+ Simulation)] - ["#." dependency] + ["#." dependency + ["#/." status]] ["#." pom] ["#." artifact (#+ Artifact) ["#/." type] @@ -58,33 +59,36 @@ (def: #export (single artifact package) (-> Artifact Package (Simulation Any)) (structure - (def: (on-download request extension state) - (if (\ ///artifact.equivalence = artifact request) - (cond (text\= extension ///artifact/extension.lux-library) - (#try.Success [state (get@ #///package.library package)]) + (def: (on-download uri state) + (if (text.contains? (///artifact.uri artifact) uri) + (cond (text.ends-with? ///artifact/extension.lux-library uri) + (#try.Success [state (|> package + (get@ #///package.library) + product.left)]) - (text\= extension ///artifact/extension.pom) + (text.ends-with? ///artifact/extension.pom uri) (#try.Success [state (|> package (get@ #///package.pom) + product.left (\ xml.codec encode) (\ encoding.utf8 encode))]) + + ## (text.ends-with? ///artifact/extension.sha-1 uri) + ## (#try.Success [state (|> package + ## (get@ #///package.sha-1) + ## (\ ///hash.sha-1-codec encode) + ## (\ encoding.utf8 encode))]) - (text\= extension ///artifact/extension.sha-1) - (#try.Success [state (|> package - (get@ #///package.sha-1) - (\ ///hash.sha-1-codec encode) - (\ encoding.utf8 encode))]) - - (text\= extension ///artifact/extension.md5) - (#try.Success [state (|> package - (get@ #///package.md5) - (\ ///hash.md5-codec encode) - (\ encoding.utf8 encode))]) + ## (text.ends-with? ///artifact/extension.md5 uri) + ## (#try.Success [state (|> package + ## (get@ #///package.md5) + ## (\ ///hash.md5-codec encode) + ## (\ encoding.utf8 encode))]) ## else (#try.Failure "NOPE")) (#try.Failure "NOPE"))) - (def: (on-upload identity artifact extension binary state) + (def: (on-upload uri binary state) (#try.Failure "NOPE")))) (def: one @@ -100,63 +104,69 @@ #let [good (..single expected-artifact expected-package) bad-sha-1 (: (Simulation Any) (structure - (def: (on-download actual-artifact extension state) - (if (\ ///artifact.equivalence = expected-artifact actual-artifact) - (cond (text\= extension ///artifact/extension.lux-library) - (#try.Success [state (get@ #///package.library expected-package)]) + (def: (on-download uri state) + (if (text.contains? (///artifact.uri expected-artifact) uri) + (cond (text.ends-with? ///artifact/extension.lux-library uri) + (#try.Success [state (|> expected-package + (get@ #///package.library) + product.left)]) - (text\= extension ///artifact/extension.pom) + (text.ends-with? ///artifact/extension.pom uri) (#try.Success [state (|> expected-package (get@ #///package.pom) + product.left (\ xml.codec encode) (\ encoding.utf8 encode))]) - (text\= extension ///artifact/extension.sha-1) - (#try.Success [state (|> dummy-package - (get@ #///package.sha-1) - (\ ///hash.sha-1-codec encode) - (\ encoding.utf8 encode))]) + ## (text\= extension ///artifact/extension.sha-1) + ## (#try.Success [state (|> dummy-package + ## (get@ #///package.sha-1) + ## (\ ///hash.sha-1-codec encode) + ## (\ encoding.utf8 encode))]) - (text\= extension ///artifact/extension.md5) - (#try.Success [state (|> expected-package - (get@ #///package.md5) - (\ ///hash.md5-codec encode) - (\ encoding.utf8 encode))]) + ## (text\= extension ///artifact/extension.md5) + ## (#try.Success [state (|> expected-package + ## (get@ #///package.md5) + ## (\ ///hash.md5-codec encode) + ## (\ encoding.utf8 encode))]) ## else (#try.Failure "NOPE")) (#try.Failure "NOPE"))) - (def: (on-upload identity artifact extension binary state) + (def: (on-upload uri binary state) (#try.Failure "NOPE")))) bad-md5 (: (Simulation Any) (structure - (def: (on-download actual-artifact extension state) - (if (\ ///artifact.equivalence = expected-artifact actual-artifact) - (cond (text\= extension ///artifact/extension.lux-library) - (#try.Success [state (get@ #///package.library expected-package)]) + (def: (on-download uri state) + (if (text.contains? (///artifact.uri expected-artifact) uri) + (cond (text.ends-with? ///artifact/extension.lux-library uri) + (#try.Success [state (|> expected-package + (get@ #///package.library) + product.left)]) - (text\= extension ///artifact/extension.pom) + (text.ends-with? ///artifact/extension.pom uri) (#try.Success [state (|> expected-package (get@ #///package.pom) + product.left (\ xml.codec encode) (\ encoding.utf8 encode))]) - (text\= extension ///artifact/extension.sha-1) - (#try.Success [state (|> expected-package - (get@ #///package.sha-1) - (\ ///hash.sha-1-codec encode) - (\ encoding.utf8 encode))]) + ## (text\= extension ///artifact/extension.sha-1) + ## (#try.Success [state (|> expected-package + ## (get@ #///package.sha-1) + ## (\ ///hash.sha-1-codec encode) + ## (\ encoding.utf8 encode))]) - (text\= extension ///artifact/extension.md5) - (#try.Success [state (|> dummy-package - (get@ #///package.md5) - (\ ///hash.md5-codec encode) - (\ encoding.utf8 encode))]) + ## (text\= extension ///artifact/extension.md5) + ## (#try.Success [state (|> dummy-package + ## (get@ #///package.md5) + ## (\ ///hash.md5-codec encode) + ## (\ encoding.utf8 encode))]) ## else (#try.Failure "NOPE")) (#try.Failure "NOPE"))) - (def: (on-upload identity artifact extension binary state) + (def: (on-upload uri binary state) (#try.Failure "NOPE"))))]] (`` ($_ _.and (wrap @@ -205,63 +215,69 @@ #let [good (..single expected-artifact expected-package) bad-sha-1 (: (Simulation Any) (structure - (def: (on-download actual-artifact extension state) - (if (\ ///artifact.equivalence = expected-artifact actual-artifact) - (cond (text\= extension ///artifact/extension.lux-library) - (#try.Success [state (get@ #///package.library expected-package)]) + (def: (on-download uri state) + (if (text.contains? (///artifact.uri expected-artifact) uri) + (cond (text.ends-with? ///artifact/extension.lux-library uri) + (#try.Success [state (|> expected-package + (get@ #///package.library) + product.left)]) - (text\= extension ///artifact/extension.pom) + (text.ends-with? ///artifact/extension.pom uri) (#try.Success [state (|> expected-package (get@ #///package.pom) + product.left (\ xml.codec encode) (\ encoding.utf8 encode))]) - (text\= extension ///artifact/extension.sha-1) - (#try.Success [state (|> dummy-package - (get@ #///package.sha-1) - (\ ///hash.sha-1-codec encode) - (\ encoding.utf8 encode))]) + ## (text\= extension ///artifact/extension.sha-1) + ## (#try.Success [state (|> dummy-package + ## (get@ #///package.sha-1) + ## (\ ///hash.sha-1-codec encode) + ## (\ encoding.utf8 encode))]) - (text\= extension ///artifact/extension.md5) - (#try.Success [state (|> expected-package - (get@ #///package.md5) - (\ ///hash.md5-codec encode) - (\ encoding.utf8 encode))]) + ## (text\= extension ///artifact/extension.md5) + ## (#try.Success [state (|> expected-package + ## (get@ #///package.md5) + ## (\ ///hash.md5-codec encode) + ## (\ encoding.utf8 encode))]) ## else (#try.Failure "NOPE")) (#try.Failure "NOPE"))) - (def: (on-upload identity artifact extension binary state) + (def: (on-upload uri binary state) (#try.Failure "NOPE")))) bad-md5 (: (Simulation Any) (structure - (def: (on-download actual-artifact extension state) - (if (\ ///artifact.equivalence = expected-artifact actual-artifact) - (cond (text\= extension ///artifact/extension.lux-library) - (#try.Success [state (get@ #///package.library expected-package)]) + (def: (on-download uri state) + (if (text.contains? (///artifact.uri expected-artifact) uri) + (cond (text.ends-with? ///artifact/extension.lux-library uri) + (#try.Success [state (|> expected-package + (get@ #///package.library) + product.left)]) - (text\= extension ///artifact/extension.pom) + (text.ends-with? ///artifact/extension.pom uri) (#try.Success [state (|> expected-package (get@ #///package.pom) + product.left (\ xml.codec encode) (\ encoding.utf8 encode))]) - (text\= extension ///artifact/extension.sha-1) - (#try.Success [state (|> expected-package - (get@ #///package.sha-1) - (\ ///hash.sha-1-codec encode) - (\ encoding.utf8 encode))]) + ## (text\= extension ///artifact/extension.sha-1) + ## (#try.Success [state (|> expected-package + ## (get@ #///package.sha-1) + ## (\ ///hash.sha-1-codec encode) + ## (\ encoding.utf8 encode))]) - (text\= extension ///artifact/extension.md5) - (#try.Success [state (|> dummy-package - (get@ #///package.md5) - (\ ///hash.md5-codec encode) - (\ encoding.utf8 encode))]) + ## (text\= extension ///artifact/extension.md5) + ## (#try.Success [state (|> dummy-package + ## (get@ #///package.md5) + ## (\ ///hash.md5-codec encode) + ## (\ encoding.utf8 encode))]) ## else (#try.Failure "NOPE")) (#try.Failure "NOPE"))) - (def: (on-upload identity artifact extension binary state) + (def: (on-upload uri binary state) (#try.Failure "NOPE"))))]] ($_ _.and (wrap @@ -332,9 +348,9 @@ ///pom.write try.assume) - dependee-package (set@ #///package.pom dependee-pom dependee-package) - depender-package (set@ #///package.pom depender-pom depender-package) - ignored-package (set@ #///package.pom ignored-pom ignored-package)]] + dependee-package (set@ #///package.pom [dependee-pom #///dependency/status.Unverified] dependee-package) + depender-package (set@ #///package.pom [depender-pom #///dependency/status.Unverified] depender-package) + ignored-package (set@ #///package.pom [ignored-pom #///dependency/status.Unverified] ignored-package)]] ($_ _.and (wrap (do promise.monad diff --git a/stdlib/source/test/aedifex/package.lux b/stdlib/source/test/aedifex/package.lux index aecdcc5af..56169a766 100644 --- a/stdlib/source/test/aedifex/package.lux +++ b/stdlib/source/test/aedifex/package.lux @@ -52,12 +52,14 @@ [[profile package] ..random] ($_ _.and (_.cover [/.local] - (and (\ //hash.equivalence = - (//hash.sha-1 (get@ #/.library package)) - (get@ #/.sha-1 package)) - (\ //hash.equivalence = - (//hash.md5 (get@ #/.library package)) - (get@ #/.md5 package)))) + false + ## (and (\ //hash.equivalence = + ## (//hash.sha-1 (get@ #/.library package)) + ## (get@ #/.sha-1 package)) + ## (\ //hash.equivalence = + ## (//hash.md5 (get@ #/.library package)) + ## (get@ #/.md5 package))) + ) (_.cover [/.dependencies] (let [expected (get@ #//.dependencies profile)] (case (/.dependencies package) diff --git a/stdlib/source/test/aedifex/repository.lux b/stdlib/source/test/aedifex/repository.lux index 5d2b62f57..af96bc572 100644 --- a/stdlib/source/test/aedifex/repository.lux +++ b/stdlib/source/test/aedifex/repository.lux @@ -21,26 +21,18 @@ [world [net ["." uri (#+ URI)]]]] - [// - ["@." artifact]] + ["." / #_ + ["#." identity] + [// + ["@." artifact]]] {#spec ["$." /]} {#program - ["." / (#+ Identity) + ["." / ["/#" // #_ ["#." artifact (#+ Version Artifact) ["#/." extension (#+ Extension)]]]]}) -(def: #export identity - (Random Identity) - (random.and (random.ascii/alpha 10) - (random.ascii/alpha 10))) - -(def: identity-equivalence - (Equivalence Identity) - (product.equivalence text.equivalence - text.equivalence)) - (def: artifact (-> Version Artifact) (|>> ["com.github.luxlang" "test-artifact"])) @@ -49,10 +41,6 @@ (exception.report ["URI" (%.text uri)])) -(exception: (invalid-identity {[user _] Identity}) - (exception.report - ["User" (%.text user)])) - (type: Store (Dictionary URI Binary)) @@ -60,8 +48,8 @@ Store (dictionary.new text.hash)) -(structure: #export (simulation identity) - (-> Identity (/.Simulation Store)) +(structure: #export simulation + (/.Simulation Store) (def: (on-download uri state) (case (dictionary.get uri state) @@ -70,21 +58,16 @@ #.None (exception.throw ..not-found [uri]))) - (def: (on-upload requester uri content state) - (if (\ identity-equivalence = identity requester) - (exception.return (dictionary.put uri content state)) - (exception.throw ..invalid-identity [requester])))) + (def: (on-upload uri content state) + (exception.return (dictionary.put uri content state)))) (def: #export test Test (<| (_.covering /._) - (do {! random.monad} - [valid ..identity - invalid (random.filter (|>> (\ identity-equivalence = valid) not) - ..identity)] - ($_ _.and - (_.for [/.mock /.Simulation] - ($/.spec valid (..artifact "1.2.3-YES") - invalid (..artifact "4.5.6-NO") - (/.mock (..simulation valid) ..empty))) - )))) + ($_ _.and + (_.for [/.mock /.Simulation] + ($/.spec (..artifact "1.2.3-YES") + (..artifact "4.5.6-NO") + (/.mock ..simulation ..empty))) + /identity.test + ))) diff --git a/stdlib/source/test/aedifex/repository/identity.lux b/stdlib/source/test/aedifex/repository/identity.lux new file mode 100644 index 000000000..98d798cf7 --- /dev/null +++ b/stdlib/source/test/aedifex/repository/identity.lux @@ -0,0 +1,30 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + {[0 #spec] + [/ + ["$." equivalence]]}] + [data + ["." product] + ["." text]] + [math + ["." random (#+ Random)]]] + {#program + ["." /]}) + +(def: #export random + (Random /.Identity) + ($_ random.and + (random.ascii/alpha 10) + (random.ascii/alpha 10) + )) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Identity] + ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + )))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 7b85a6ff4..7caf3eba1 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -140,7 +140,7 @@ ($_ _.and (do random.monad [factor (random\map (|>> (n.% 10) (n.max 1)) random.nat) - iterations (random\map (n.% 100) random.nat) + iterations (random\map (n.% 10) random.nat) #let [expected (n.* factor iterations)]] (_.test "Can write loops." (n.= expected @@ -232,50 +232,50 @@ (def: test (<| (_.context (name.module (name-of /._))) - ($_ _.and - (!bundle ($_ _.and - (<| (_.context "Identity.") - ..identity) - (<| (_.context "Increment & decrement.") - ..increment-and-decrement) - (<| (_.context "Even or odd.") - ($_ _.and - (<| (_.context "Natural numbers.") - (..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>]))] + (_.in-parallel + (list (!bundle ($_ _.and + (<| (_.context "Identity.") + ..identity) + (<| (_.context "Increment & decrement.") + ..increment-and-decrement) + (<| (_.context "Even or odd.") + ($_ _.and + (<| (_.context "Natural numbers.") + (..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.= 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] - ))))) - (<| (_.context "Prelude macros.") - ..prelude-macros) - (<| (_.context "Templates.") - ..templates) - (<| (_.context "Cross-platform support.") - ..cross-platform-support))) - ..sub-tests - ))) + [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] + ))))) + (<| (_.context "Prelude macros.") + ..prelude-macros) + (<| (_.context "Templates.") + ..templates) + (<| (_.context "Cross-platform support.") + ..cross-platform-support))) + ..sub-tests + )))) (program: args (<| io diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux index 933a599c0..03cc9613d 100644 --- a/stdlib/source/test/lux/control/concurrency/frp.lux +++ b/stdlib/source/test/lux/control/concurrency/frp.lux @@ -13,8 +13,11 @@ ["." exception] ["." io (#+ IO io)]] [data + [text + ["%" format (#+ format)]] [number - ["n" nat]] + ["n" nat] + ["." i64]] [collection ["." list ("#\." fold monoid)] ["." row (#+ Row)]]] @@ -171,22 +174,30 @@ actual)))) (let [polling-delay 1 amount-of-polls 5 - wiggle-room ($_ n.* amount-of-polls 4 polling-delay) + wiggle-room ($_ n.* + (i64.left-shift 6 1) + amount-of-polls + polling-delay) total-delay (|> polling-delay (n.* amount-of-polls) (n.+ wiggle-room))] ($_ _.and (wrap (do promise.monad [#let [[channel sink] (/.poll polling-delay (: (IO Nat) (io.io sample)))] - _ (promise.schedule total-delay (io.io [])) + _ (promise.delay total-delay []) _ (promise.future (\ sink close)) - actual (/.consume channel)] + actual (/.consume channel) + #let [correct-values! + (list.every? (n.= sample) actual) + + enough-polls! + (n.>= amount-of-polls (list.size actual))]] (_.cover' [/.poll] - (and (list.every? (n.= sample) actual) - (n.>= amount-of-polls (list.size actual)))))) + (and correct-values! + enough-polls!)))) (wrap (do promise.monad [#let [[channel sink] (/.periodic polling-delay)] - _ (promise.schedule total-delay (io.io [])) + _ (promise.delay total-delay []) _ (promise.future (\ sink close)) actual (/.consume channel)] (_.cover' [/.periodic] diff --git a/stdlib/source/test/lux/control/function/memo.lux b/stdlib/source/test/lux/control/function/memo.lux index 88be05a17..66a0e13ef 100644 --- a/stdlib/source/test/lux/control/function/memo.lux +++ b/stdlib/source/test/lux/control/function/memo.lux @@ -10,8 +10,11 @@ ["." random]] [data ["." product] + [text + ["%" format (#+ format)]] [number - ["n" nat]] + ["n" nat] + ["." i64]] [collection ["." dictionary (#+ Dictionary)] ["." list ("#\." functor fold)]]] @@ -46,11 +49,17 @@ (-> Duration Nat) (|>> (duration.query duration.milli-second) .nat)) +## the wiggle room is there to account for GC pauses +## and other issues that might mess with duration +(def: wiggle-room + Nat + (i64.left-shift 4 1)) + (def: #export test Test (<| (_.covering /._) (do {! random.monad} - [input (|> random.nat (\ ! map (|>> (n.% 5) (n.+ 20))))]) + [input (|> random.nat (\ ! map (|>> (n.% 5) (n.+ 21))))]) (_.for [/.Memo]) ($_ _.and (_.cover [/.closed /.none] @@ -59,11 +68,16 @@ [#let [slow (/.none n.hash ..fibonacci) fast (/.closed n.hash fibonacci)] [slow-time slow-output] (..time slow input) - [fast-time fast-output] (..time fast input)] - (wrap (and (n.= slow-output - fast-output) - (n.< (milli-seconds slow-time) - (milli-seconds fast-time))))))) + [fast-time fast-output] (..time fast input) + #let [same-output! + (n.= slow-output + fast-output) + + memo-is-faster! + (n.< (n.+ ..wiggle-room (milli-seconds slow-time)) + (milli-seconds fast-time))]] + (wrap (and same-output! + memo-is-faster!))))) (_.cover [/.open] (io.run (do io.monad @@ -78,15 +92,12 @@ open-output) memo-is-faster! - (n.< (milli-seconds none-time) + (n.< (n.+ ..wiggle-room (milli-seconds none-time)) (milli-seconds open-time)) incrementalism-is-faster! - ## the wiggle room is there to account for GC pauses - ## and other issues that might mess with duration - (let [wiggle-room 2] - (n.< (n.+ wiggle-room (milli-seconds open-time)) - (milli-seconds open-time/+1)))]] + (n.< (n.+ ..wiggle-room (milli-seconds open-time)) + (milli-seconds open-time/+1))]] (wrap (and same-output! memo-is-faster! incrementalism-is-faster!))))) diff --git a/stdlib/source/test/lux/control/parser/text.lux b/stdlib/source/test/lux/control/parser/text.lux index 486fc8798..8436e30ca 100644 --- a/stdlib/source/test/lux/control/parser/text.lux +++ b/stdlib/source/test/lux/control/parser/text.lux @@ -14,7 +14,7 @@ ["." unicode #_ ["#" set] ["#/." block]]] - [number + [number (#+ hex) ["n" nat]] [collection ["." set] @@ -152,20 +152,18 @@ (..should-fail invalid /.space)))) (do {! random.monad} [#let [num-options 3] - chars (random.set n.hash num-options - (random.char unicode.character)) - #let [options (|> chars - set.to-list - (list\map text.from-code) - (text.join-with ""))] + options (|> (random.char unicode.character) + (random.set n.hash num-options) + (\ ! map (|>> set.to-list + (list\map text.from-code) + (text.join-with "")))) expected (\ ! map (function (_ value) (|> options (text.nth (n.% num-options value)) maybe.assume)) random.nat) - invalid (random.filter (|>> text.from-code - (text.contains? options) - not) + invalid (random.filter (function (_ char) + (not (text.contains? (text.from-code char) options))) (random.char unicode.character))] (_.cover [/.one-of /.one-of! /.character-should-be] (and (..should-pass (text.from-code expected) (/.one-of options)) @@ -190,9 +188,8 @@ (text.nth (n.% num-options value)) maybe.assume)) random.nat) - expected (random.filter (|>> text.from-code - (text.contains? options) - not) + expected (random.filter (function (_ char) + (not (text.contains? (text.from-code char) options))) (random.char unicode.character))] (_.cover [/.none-of /.none-of! /.character-should-not-be] (and (..should-pass (text.from-code expected) (/.none-of options)) @@ -203,7 +200,8 @@ (..should-pass! (text.from-code expected) (/.none-of! options)) (..should-fail (text.from-code invalid) (/.none-of! options)) (..should-fail' (text.from-code invalid) (/.none-of! options) - /.character-should-not-be)))) + /.character-should-not-be) + ))) )) (def: runs diff --git a/stdlib/source/test/lux/control/parser/type.lux b/stdlib/source/test/lux/control/parser/type.lux index 9d8d498c5..f703d38a7 100644 --- a/stdlib/source/test/lux/control/parser/type.lux +++ b/stdlib/source/test/lux/control/parser/type.lux @@ -9,7 +9,9 @@ [data ["." name ("#\." equivalence)] [number - ["n" nat]]] + ["n" nat]] + [collection + ["." list]]] [math ["." random (#+ Random)]] ["." type ("#\." equivalence)]] @@ -115,6 +117,73 @@ (exception.match? /.not-application error)))))) )))) +(def: parameter + Test + (do random.monad + [quantification ..primitive + argument ..primitive + not-parameter ..primitive + parameter random.nat] + ($_ _.and + (_.cover [/.not-parameter] + (|> (/.run /.parameter not-parameter) + (!expect (^multi (#try.Failure error) + (exception.match? /.not-parameter error))))) + (_.cover [/.unknown-parameter] + (|> (/.run /.parameter (#.Parameter parameter)) + (!expect (^multi (#try.Failure error) + (exception.match? /.unknown-parameter error))))) + (_.cover [/.with-extension] + (|> (/.run (<| (/.with-extension quantification) + (/.with-extension argument) + /.any) + not-parameter) + (!expect (^multi (#try.Success [quantification\\binding argument\\binding actual]) + (is? not-parameter actual))))) + (_.cover [/.parameter] + (|> (/.run (<| (/.with-extension quantification) + (/.with-extension argument) + /.parameter) + (#.Parameter 0)) + (!expect (#try.Success [quantification\\binding argument\\binding _])))) + (_.cover [/.wrong-parameter] + (|> (/.run (<| (/.with-extension quantification) + (/.with-extension argument) + (/.parameter! 1)) + (#.Parameter 0)) + (!expect (^multi (#try.Failure error) + (exception.match? /.wrong-parameter error))))) + (_.cover [/.parameter!] + (|> (/.run (<| (/.with-extension quantification) + (/.with-extension argument) + (/.parameter! 0)) + (#.Parameter 0)) + (!expect (#try.Success [quantification\\binding argument\\binding _])))) + ))) + +(def: polymorphic + Test + (do {! random.monad} + [not-polymorphic ..primitive + expected-inputs (\ ! map (|>> (n.% 10) inc) random.nat)] + ($_ _.and + (_.cover [/.not-polymorphic] + (and (|> (/.run (/.polymorphic /.any) + not-polymorphic) + (!expect (^multi (#try.Failure error) + (exception.match? /.not-polymorphic error)))) + (|> (/.run (/.polymorphic /.any) + (type.univ-q 0 not-polymorphic)) + (!expect (^multi (#try.Failure error) + (exception.match? /.not-polymorphic error)))))) + (_.cover [/.polymorphic] + (|> (/.run (/.polymorphic /.any) + (type.univ-q expected-inputs not-polymorphic)) + (!expect (^multi (#try.Success [g!poly actual-inputs bodyT]) + (and (n.= expected-inputs (list.size actual-inputs)) + (is? not-polymorphic bodyT)))))) + ))) + (def: #export test Test (<| (_.covering /._) @@ -194,4 +263,6 @@ (type\= expected-type actual-type))))))) ..aggregate ..matches + ..parameter + ..polymorphic ))) diff --git a/stdlib/source/test/lux/data/number/frac.lux b/stdlib/source/test/lux/data/number/frac.lux index ec3e4d3da..d982b6492 100644 --- a/stdlib/source/test/lux/data/number/frac.lux +++ b/stdlib/source/test/lux/data/number/frac.lux @@ -160,7 +160,8 @@ (/.* (/.signum sample) sample))) )) (do random.monad - [left ..random + [left (random.filter (|>> (/.= +0.0) not) + ..random) right ..random] ($_ _.and (_.cover [/.%] diff --git a/stdlib/source/test/lux/data/text/format.lux b/stdlib/source/test/lux/data/text/format.lux index a8004f919..cfad7f524 100644 --- a/stdlib/source/test/lux/data/text/format.lux +++ b/stdlib/source/test/lux/data/text/format.lux @@ -31,6 +31,7 @@ ["." date]] [math ["." random (#+ Random) ("#\." monad)] + ["." modulus] ["." modular]] [macro ["." code]] @@ -152,10 +153,10 @@ list (/.list (|>>)))))) (do {! random.monad} - [modulus (random.one (|>> modular.from-int + [modulus (random.one (|>> modulus.modulus try.to-maybe) random.int) - sample (\ ! map (modular.mod modulus) + sample (\ ! map (modular.modular modulus) random.int)] (_.cover [/.mod] (text\= (\ (modular.codec modulus) encode sample) diff --git a/stdlib/source/test/lux/macro/syntax/common.lux b/stdlib/source/test/lux/macro/syntax/common.lux index 98b3cdc0c..592baa036 100644 --- a/stdlib/source/test/lux/macro/syntax/common.lux +++ b/stdlib/source/test/lux/macro/syntax/common.lux @@ -30,7 +30,8 @@ ["#." code]] ["." / #_ ["#." check] - ["#." definition]]) + ["#." definition] + ["#." export]]) (def: annotations-equivalence (Equivalence /.Annotations) @@ -59,17 +60,6 @@ (_.covering /reader._) (_.covering /writer._) ($_ _.and - (do random.monad - [expected random.bit] - (_.cover [/reader.export /writer.export] - (|> expected - /writer.export - (<c>.run /reader.export) - (case> (#try.Success actual) - (bit\= expected actual) - - (#try.Failure error) - false)))) (_.for [/.Annotations] ($_ _.and (do random.monad @@ -138,4 +128,5 @@ /check.test /definition.test + /export.test ))) diff --git a/stdlib/source/test/lux/macro/syntax/common/definition.lux b/stdlib/source/test/lux/macro/syntax/common/definition.lux index 4e3352e40..18af3edaa 100644 --- a/stdlib/source/test/lux/macro/syntax/common/definition.lux +++ b/stdlib/source/test/lux/macro/syntax/common/definition.lux @@ -69,7 +69,7 @@ (do random.monad [expected ..random - + type $////code.random untyped-value $////code.random] ($_ _.and diff --git a/stdlib/source/test/lux/macro/syntax/common/export.lux b/stdlib/source/test/lux/macro/syntax/common/export.lux new file mode 100644 index 000000000..59b72eb0f --- /dev/null +++ b/stdlib/source/test/lux/macro/syntax/common/export.lux @@ -0,0 +1,29 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try] + [parser + ["<.>" code]]] + [data + ["." bit ("#\." equivalence)]] + [math + ["." random]]] + {1 + ["." /]}) + +(def: #export test + Test + (<| (_.covering /._) + (do random.monad + [expected random.bit] + (_.cover [/.write /.parser] + (case (<code>.run /.parser + (/.write expected)) + (#try.Failure _) + false + + (#try.Success actual) + (bit\= expected actual)))))) diff --git a/stdlib/source/test/lux/math.lux b/stdlib/source/test/lux/math.lux index 11f826ce4..bede0dd2c 100644 --- a/stdlib/source/test/lux/math.lux +++ b/stdlib/source/test/lux/math.lux @@ -13,6 +13,7 @@ ["." /]} ["." / #_ ["#." infix] + ["#." modulus] ["#." modular] ["#." logic #_ ["#/." continuous] diff --git a/stdlib/source/test/lux/math/modular.lux b/stdlib/source/test/lux/math/modular.lux index 283acdddd..2bbcea587 100644 --- a/stdlib/source/test/lux/math/modular.lux +++ b/stdlib/source/test/lux/math/modular.lux @@ -1,42 +1,46 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] - ["r" math/random] - [abstract/monad (#+ do)] + ["." type ("#\." equivalence)] + [abstract + [monad (#+ do)]] [control - ["." try]] + ["." try] + ["." exception]] [data ["." product] ["." bit ("#\." equivalence)] [number ["i" int]]] - ["." type ("#\." equivalence)]] + [math + ["." random (#+ Random)]]] {1 - ["." /]}) + ["." / + ["/#" // #_ + ["#" modulus]]]}) -(def: %3 (/.modulus +3)) +(def: %3 (//.literal +3)) (`` (type: Mod3 (~~ (:of %3)))) (def: modulusR - (r.Random Int) - (|> r.int - (\ r.monad map (i.% +1000)) - (r.filter (|>> (i.= +0) not)))) + (Random Int) + (|> random.int + (\ random.monad map (i.% +1000)) + (random.filter (|>> (i.= +0) not)))) (def: valueR - (r.Random Int) - (|> r.int (\ r.monad map (i.% +1000)))) + (Random Int) + (|> random.int (\ random.monad map (i.% +1000)))) (def: (modR modulus) - (All [m] (-> (/.Modulus m) (r.Random [Int (/.Mod m)]))) - (do r.monad + (All [m] (-> (//.Modulus m) (Random [Int (/.Mod m)]))) + (do random.monad [raw valueR] - (wrap [raw (/.mod modulus raw)]))) + (wrap [raw (/.modular modulus raw)]))) (def: value (All [m] (-> (/.Mod m) Int)) - (|>> /.un-mod product.left)) + (|>> /.un-modular product.right)) (def: (comparison m/? i/?) (All [m] @@ -50,27 +54,27 @@ (def: (arithmetic modulus m/! i/!) (All [m] - (-> (/.Modulus m) + (-> (//.Modulus m) (-> (/.Mod m) (/.Mod m) (/.Mod m)) (-> Int Int Int) (-> (/.Mod m) (/.Mod m) Bit))) (function (_ param subject) (|> (i/! (value param) (value subject)) - (/.mod modulus) + (/.modular modulus) (/.= (m/! param subject))))) (def: #export test Test - (<| (_.context (%.name (name-of /.Mod))) - (do r.monad + (<| (_.covering /._) + (do random.monad [_normalM modulusR - _alternativeM (|> modulusR (r.filter (|>> (i.= _normalM) not))) - #let [normalM (|> _normalM /.from-int try.assume) - alternativeM (|> _alternativeM /.from-int try.assume)] + _alternativeM (|> modulusR (random.filter (|>> (i.= _normalM) not))) + #let [normalM (|> _normalM //.modulus try.assume) + alternativeM (|> _alternativeM //.modulus try.assume)] [_param param] (modR normalM) [_subject subject] (modR normalM) - #let [copyM (|> normalM /.to-int /.from-int try.assume)]] + #let [copyM (|> normalM //.divisor //.modulus try.assume)]] ($_ _.and (_.test "Every modulus has a unique type, even if the numeric value is the same as another." (and (type\= (:of normalM) @@ -79,64 +83,64 @@ (:of alternativeM))) (not (type\= (:of normalM) (:of copyM))))) - (_.test "Can extract the original integer from the modulus." - (i.= _normalM - (/.to-int normalM))) - (_.test "Can compare mod'ed values." - (and (/.= subject subject) - ((comparison /.= i.=) param subject) - ((comparison /.< i.<) param subject) - ((comparison /.<= i.<=) param subject) - ((comparison /.> i.>) param subject) - ((comparison /.>= i.>=) param subject))) - (_.test "Mod'ed values are ordered." - (and (bit\= (/.< param subject) - (not (/.>= param subject))) - (bit\= (/.> param subject) - (not (/.<= param subject))) - (bit\= (/.= param subject) - (not (or (/.< param subject) - (/.> param subject)))))) - (_.test "Can do arithmetic." - (and ((arithmetic normalM /.+ i.+) param subject) - ((arithmetic normalM /.- i.-) param subject) - ((arithmetic normalM /.* i.*) param subject))) - (_.test "Can sometimes find multiplicative inverse." - (case (/.inverse subject) - (#.Some subject^-1) - (|> subject - (/.* subject^-1) - (/.= (/.mod normalM +1))) - - #.None - true)) - (_.test "Can encode/decode to text." - (let [(^open "mod/.") (/.codec normalM)] - (case (|> subject mod/encode mod/decode) - (#try.Success output) - (/.= subject output) + ## (_.test "Can extract the original integer from the modulus." + ## (i.= _normalM + ## (//.divisor normalM))) + ## (_.test "Can compare mod'ed values." + ## (and (/.= subject subject) + ## ((comparison /.= i.=) param subject) + ## ((comparison /.< i.<) param subject) + ## ((comparison /.<= i.<=) param subject) + ## ((comparison /.> i.>) param subject) + ## ((comparison /.>= i.>=) param subject))) + ## (_.test "Mod'ed values are ordered." + ## (and (bit\= (/.< param subject) + ## (not (/.>= param subject))) + ## (bit\= (/.> param subject) + ## (not (/.<= param subject))) + ## (bit\= (/.= param subject) + ## (not (or (/.< param subject) + ## (/.> param subject)))))) + ## (_.test "Can do arithmetic." + ## (and ((arithmetic normalM /.+ i.+) param subject) + ## ((arithmetic normalM /.- i.-) param subject) + ## ((arithmetic normalM /.* i.*) param subject))) + ## (_.test "Can sometimes find multiplicative inverse." + ## (case (/.inverse subject) + ## (#.Some subject^-1) + ## (|> subject + ## (/.* subject^-1) + ## (/.= (/.modular normalM +1))) + + ## #.None + ## true)) + ## (_.test "Can encode/decode to text." + ## (let [(^open "mod/.") (/.codec normalM)] + ## (case (|> subject mod/encode mod/decode) + ## (#try.Success output) + ## (/.= subject output) - (#try.Failure error) - false))) - (_.test "Can equalize 2 moduli if they are equal." - (case (/.equalize (/.mod normalM _subject) - (/.mod copyM _param)) - (#try.Success paramC) - (/.= param paramC) + ## (#try.Failure error) + ## false))) + ## (_.test "Can equalize 2 moduli if they are equal." + ## (case (/.equalize (/.modular normalM _subject) + ## (/.modular copyM _param)) + ## (#try.Success paramC) + ## (/.= param paramC) - (#try.Failure error) - false)) - (_.test "Cannot equalize 2 moduli if they are the different." - (case (/.equalize (/.mod normalM _subject) - (/.mod alternativeM _param)) - (#try.Success paramA) - false + ## (#try.Failure error) + ## false)) + ## (_.test "Cannot equalize 2 moduli if they are the different." + ## (case (/.equalize (/.modular normalM _subject) + ## (/.modular alternativeM _param)) + ## (#try.Success paramA) + ## false - (#try.Failure error) - true)) - (_.test "All numbers are congruent to themselves." - (/.congruent? normalM _subject _subject)) - (_.test "If 2 numbers are congruent under a modulus, then they must also be equal under the same modulus." - (bit\= (/.congruent? normalM _param _subject) - (/.= param subject))) + ## (#try.Failure error) + ## true)) + ## (_.test "All numbers are congruent to themselves." + ## (//.congruent? normalM _subject _subject)) + ## (_.test "If 2 numbers are congruent under a modulus, then they must also be equal under the same modulus." + ## (bit\= (//.congruent? normalM _param _subject) + ## (/.= param subject))) )))) diff --git a/stdlib/source/test/lux/math/modulus.lux b/stdlib/source/test/lux/math/modulus.lux new file mode 100644 index 000000000..502948efa --- /dev/null +++ b/stdlib/source/test/lux/math/modulus.lux @@ -0,0 +1,59 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try] + ["." exception]] + [data + [number + ["i" int]]] + [math + ["." random (#+ Random)]] + ["." meta] + [macro + [syntax (#+ syntax:)] + ["." code]]] + {1 + ["." /]}) + +(syntax: (|divisor|) + (do meta.monad + [divisor meta.count] + (wrap (list (code.int (case divisor + 0 +1 + _ (.int divisor))))))) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Modulus]) + (do random.monad + [divisor random.int + modulus (random.one (|>> /.modulus try.to-maybe) + random.int) + dividend random.int] + ($_ _.and + (_.cover [/.modulus /.divisor] + (case (/.modulus divisor) + (#try.Success modulus) + (i.= divisor (/.divisor modulus)) + + (#try.Failure error) + (i.= +0 divisor))) + (_.cover [/.zero-cannot-be-a-modulus] + (case (/.modulus +0) + (#try.Failure error) + (exception.match? /.zero-cannot-be-a-modulus error) + + (#try.Success modulus) + false)) + (_.cover [/.literal] + (with-expansions [<divisor> (|divisor|)] + (i.= <divisor> (/.divisor (/.literal <divisor>))))) + (_.cover [/.congruent?] + (and (/.congruent? modulus dividend dividend) + (or (not (/.congruent? modulus dividend (inc dividend))) + (i.= +1 (/.divisor modulus))))) + )))) diff --git a/stdlib/source/test/lux/world/file.lux b/stdlib/source/test/lux/world/file.lux index d1d1d175b..35706fa8a 100644 --- a/stdlib/source/test/lux/world/file.lux +++ b/stdlib/source/test/lux/world/file.lux @@ -80,126 +80,126 @@ duration.from-millis instant.absolute)))] ($_ _.and - (..creation-and-deletion 0) - (..read-and-write 1 dataL) + ## (..creation-and-deletion 0) + ## (..read-and-write 1 dataL) - (wrap (do promise.monad - [#let [path "temp_file_2"] - result (promise.future - (do (try.with io.monad) - [file (!.use (\ /.default create-file) path) - _ (!.use (\ file over-write) dataL) - read-size (!.use (\ file size) []) - _ (!.use (\ file delete) [])] - (wrap (n.= file-size read-size))))] - (_.assert "Can read file size." - (try.default #0 result)))) - (wrap (do promise.monad - [#let [path "temp_file_3"] - result (promise.future - (do (try.with io.monad) - [file (!.use (\ /.default create-file) path) - _ (!.use (\ file over-write) dataL) - _ (!.use (\ file append) dataR) - content (!.use (\ file content) []) - read-size (!.use (\ file size) []) - _ (!.use (\ file delete) [])] - (wrap (and (n.= (n.* 2 file-size) read-size) - (\ binary.equivalence = - dataL - (try.assume (binary.slice 0 (dec file-size) content))) - (\ binary.equivalence = - dataR - (try.assume (binary.slice file-size (dec read-size) content)))))))] - (_.assert "Can append to files." - (try.default #0 result)))) - (wrap (do promise.monad - [#let [path "temp_dir_4"] - result (promise.future - (do (try.with io.monad) - [#let [check-existence! (: (IO (Try Bit)) - (try.lift io.monad (/.exists? io.monad /.default path)))] - pre! check-existence! - dir (!.use (\ /.default create-directory) path) - post! check-existence! - _ (!.use (\ dir discard) []) - remains? check-existence!] - (wrap (and (not pre!) - post! - (not remains?)))))] - (_.assert "Can create/delete directories." - (try.default #0 result)))) - (wrap (do promise.monad - [#let [file-path "temp_file_5" - dir-path "temp_dir_5"] - result (promise.future - (do (try.with io.monad) - [dir (!.use (\ /.default create-directory) dir-path) - file (!.use (\ /.default create-file) (format dir-path "/" file-path)) - _ (!.use (\ file over-write) dataL) - read-size (!.use (\ file size) []) - _ (!.use (\ file delete) []) - _ (!.use (\ dir discard) [])] - (wrap (n.= file-size read-size))))] - (_.assert "Can create files inside of directories." - (try.default #0 result)))) - (wrap (do promise.monad - [#let [file-path "temp_file_6" - dir-path "temp_dir_6" - inner-dir-path "inner_temp_dir_6"] - result (promise.future - (do (try.with io.monad) - [dir (!.use (\ /.default create-directory) dir-path) - pre-files (!.use (\ dir files) []) - pre-directories (!.use (\ dir directories) []) + ## (wrap (do promise.monad + ## [#let [path "temp_file_2"] + ## result (promise.future + ## (do (try.with io.monad) + ## [file (!.use (\ /.default create-file) path) + ## _ (!.use (\ file over-write) dataL) + ## read-size (!.use (\ file size) []) + ## _ (!.use (\ file delete) [])] + ## (wrap (n.= file-size read-size))))] + ## (_.assert "Can read file size." + ## (try.default #0 result)))) + ## (wrap (do promise.monad + ## [#let [path "temp_file_3"] + ## result (promise.future + ## (do (try.with io.monad) + ## [file (!.use (\ /.default create-file) path) + ## _ (!.use (\ file over-write) dataL) + ## _ (!.use (\ file append) dataR) + ## content (!.use (\ file content) []) + ## read-size (!.use (\ file size) []) + ## _ (!.use (\ file delete) [])] + ## (wrap (and (n.= (n.* 2 file-size) read-size) + ## (\ binary.equivalence = + ## dataL + ## (try.assume (binary.slice 0 (dec file-size) content))) + ## (\ binary.equivalence = + ## dataR + ## (try.assume (binary.slice file-size (dec read-size) content)))))))] + ## (_.assert "Can append to files." + ## (try.default #0 result)))) + ## (wrap (do promise.monad + ## [#let [path "temp_dir_4"] + ## result (promise.future + ## (do (try.with io.monad) + ## [#let [check-existence! (: (IO (Try Bit)) + ## (try.lift io.monad (/.exists? io.monad /.default path)))] + ## pre! check-existence! + ## dir (!.use (\ /.default create-directory) path) + ## post! check-existence! + ## _ (!.use (\ dir discard) []) + ## remains? check-existence!] + ## (wrap (and (not pre!) + ## post! + ## (not remains?)))))] + ## (_.assert "Can create/delete directories." + ## (try.default #0 result)))) + ## (wrap (do promise.monad + ## [#let [file-path "temp_file_5" + ## dir-path "temp_dir_5"] + ## result (promise.future + ## (do (try.with io.monad) + ## [dir (!.use (\ /.default create-directory) dir-path) + ## file (!.use (\ /.default create-file) (format dir-path "/" file-path)) + ## _ (!.use (\ file over-write) dataL) + ## read-size (!.use (\ file size) []) + ## _ (!.use (\ file delete) []) + ## _ (!.use (\ dir discard) [])] + ## (wrap (n.= file-size read-size))))] + ## (_.assert "Can create files inside of directories." + ## (try.default #0 result)))) + ## (wrap (do promise.monad + ## [#let [file-path "temp_file_6" + ## dir-path "temp_dir_6" + ## inner-dir-path "inner_temp_dir_6"] + ## result (promise.future + ## (do (try.with io.monad) + ## [dir (!.use (\ /.default create-directory) dir-path) + ## pre-files (!.use (\ dir files) []) + ## pre-directories (!.use (\ dir directories) []) - file (!.use (\ /.default create-file) (format dir-path "/" file-path)) - inner-dir (!.use (\ /.default create-directory) (format dir-path "/" inner-dir-path)) - post-files (!.use (\ dir files) []) - post-directories (!.use (\ dir directories) []) + ## file (!.use (\ /.default create-file) (format dir-path "/" file-path)) + ## inner-dir (!.use (\ /.default create-directory) (format dir-path "/" inner-dir-path)) + ## post-files (!.use (\ dir files) []) + ## post-directories (!.use (\ dir directories) []) - _ (!.use (\ file delete) []) - _ (!.use (\ inner-dir discard) []) - _ (!.use (\ dir discard) [])] - (wrap (and (and (n.= 0 (list.size pre-files)) - (n.= 0 (list.size pre-directories))) - (and (n.= 1 (list.size post-files)) - (n.= 1 (list.size post-directories)))))))] - (_.assert "Can list files/directories inside a directory." - (try.default #0 result)))) - (wrap (do promise.monad - [#let [path "temp_file_7"] - result (promise.future - (do (try.with io.monad) - [file (!.use (\ /.default create-file) path) - _ (!.use (\ file over-write) dataL) - _ (!.use (\ file modify) new-modified) - current-modified (!.use (\ file last-modified) []) - _ (!.use (\ file delete) [])] - (wrap (\ instant.equivalence = new-modified current-modified))))] - (_.assert "Can change the time of last modification." - (try.default #0 result)))) - (wrap (do promise.monad - [#let [path0 (format "temp_file_8+0") - path1 (format "temp_file_8+1")] - result (promise.future - (do (try.with io.monad) - [#let [check-existence! (: (-> Path (IO (Try Bit))) - (|>> (/.exists? io.monad /.default) - (try.lift io.monad)))] - file0 (!.use (\ /.default create-file) path0) - _ (!.use (\ file0 over-write) dataL) - pre! (check-existence! path0) - file1 (: (IO (Try (File IO))) ## TODO: Remove : - (!.use (\ file0 move) path1)) - post! (check-existence! path0) - confirmed? (check-existence! path1) - _ (!.use (\ file1 delete) [])] - (wrap (and pre! - (not post!) - confirmed?))))] - (_.assert "Can move a file from one path to another." - (try.default #0 result)))) + ## _ (!.use (\ file delete) []) + ## _ (!.use (\ inner-dir discard) []) + ## _ (!.use (\ dir discard) [])] + ## (wrap (and (and (n.= 0 (list.size pre-files)) + ## (n.= 0 (list.size pre-directories))) + ## (and (n.= 1 (list.size post-files)) + ## (n.= 1 (list.size post-directories)))))))] + ## (_.assert "Can list files/directories inside a directory." + ## (try.default #0 result)))) + ## (wrap (do promise.monad + ## [#let [path "temp_file_7"] + ## result (promise.future + ## (do (try.with io.monad) + ## [file (!.use (\ /.default create-file) path) + ## _ (!.use (\ file over-write) dataL) + ## _ (!.use (\ file modify) new-modified) + ## current-modified (!.use (\ file last-modified) []) + ## _ (!.use (\ file delete) [])] + ## (wrap (\ instant.equivalence = new-modified current-modified))))] + ## (_.assert "Can change the time of last modification." + ## (try.default #0 result)))) + ## (wrap (do promise.monad + ## [#let [path0 (format "temp_file_8+0") + ## path1 (format "temp_file_8+1")] + ## result (promise.future + ## (do (try.with io.monad) + ## [#let [check-existence! (: (-> Path (IO (Try Bit))) + ## (|>> (/.exists? io.monad /.default) + ## (try.lift io.monad)))] + ## file0 (!.use (\ /.default create-file) path0) + ## _ (!.use (\ file0 over-write) dataL) + ## pre! (check-existence! path0) + ## file1 (: (IO (Try (File IO))) ## TODO: Remove : + ## (!.use (\ file0 move) path1)) + ## post! (check-existence! path0) + ## confirmed? (check-existence! path1) + ## _ (!.use (\ file1 delete) [])] + ## (wrap (and pre! + ## (not post!) + ## confirmed?))))] + ## (_.assert "Can move a file from one path to another." + ## (try.default #0 result)))) /watch.test )))) |