diff options
Diffstat (limited to 'stdlib')
30 files changed, 761 insertions, 589 deletions
diff --git a/stdlib/source/lux/control/parser/xml.lux b/stdlib/source/lux/control/parser/xml.lux index bea101164..8ba28d20d 100644 --- a/stdlib/source/lux/control/parser/xml.lux +++ b/stdlib/source/lux/control/parser/xml.lux @@ -22,26 +22,18 @@ (exception: #export empty-input) (exception: #export unexpected-input) -(def: (label [namespace name]) - (-> Name Text) - (format namespace ":" name)) - -(template [<exception> <type> <header>] +(template [<exception> <type> <header> <format>] [(exception: #export (<exception> {label <type>}) (exception.report - [<header> (%.text (..label label))]))] + [<header> (%.text (<format> label))]))] - [wrong-tag Tag "Tag"] - [unknown-attribute Attribute "Attribute"] + [wrong-tag Tag "Tag" /.tag] + [unknown-attribute Attribute "Attribute" /.attribute] ) -(def: blank-line - (format text.new-line text.new-line)) - (exception: #export (unconsumed-inputs {inputs (List XML)}) - (|> inputs - (list@map (:: /.codec encode)) - (text.join-with blank-line))) + (exception.report + ["Inputs" (exception.enumerate (:: /.codec encode) inputs)])) (def: #export text (Parser Text) @@ -70,7 +62,7 @@ (#/.Text _) (exception.throw ..unexpected-input []) - (#/.Node _tag _attrs _children) + (#/.Node _tag _attributes _children) (if (name@= tag _tag) (#try.Success [docs []]) (exception.throw ..wrong-tag tag)))))) @@ -87,10 +79,10 @@ (#/.Text _) (exception.throw ..unexpected-input []) - (#/.Node tag _attrs _children) + (#/.Node tag _attributes _children) (#try.Success [docs tag]))))) -(def: #export (attr name) +(def: #export (attribute name) (-> Attribute (Parser Text)) (function (_ docs) (case docs @@ -102,8 +94,8 @@ (#/.Text _) (exception.throw ..unexpected-input []) - (#/.Node tag attrs children) - (case (dictionary.get name attrs) + (#/.Node tag attributes children) + (case (dictionary.get name attributes) #.None (exception.throw ..unknown-attribute [name]) @@ -133,7 +125,7 @@ (#/.Text _) (exception.throw ..unexpected-input []) - (#/.Node _tag _attrs children) + (#/.Node _tag _attributes children) (do try.monad [output (run' parser children)] (wrap [tail output])))))) @@ -151,3 +143,23 @@ (def: #export (run parser document) (All [a] (-> (Parser a) XML (Try a))) (..run' parser (list document))) + +(exception: #export nowhere) + +(def: #export (somewhere parser) + (All [a] (-> (Parser a) (Parser a))) + (function (recur input) + (case (//.run parser input) + (#try.Success [remaining output]) + (#try.Success [remaining output]) + + (#try.Failure error) + (case input + #.Nil + (exception.throw ..nowhere []) + + (#.Cons head tail) + (do try.monad + [[tail' output] (recur tail)] + (wrap [(#.Cons head tail') + output])))))) diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux index a71acfb44..9244ebe84 100644 --- a/stdlib/source/lux/data/collection/dictionary.lux +++ b/stdlib/source/lux/data/collection/dictionary.lux @@ -599,14 +599,14 @@ {#.doc (doc "Updates the value at the key; if it exists." "Otherwise, puts a value by applying the function to a default.")} (All [k v] (-> k v (-> v v) (Dictionary k v) (Dictionary k v))) - (put key - (f (maybe.default default - (get key dict))) - dict)) + (..put key + (f (maybe.default default + (..get key dict))) + dict)) (def: #export size (All [k v] (-> (Dictionary k v) Nat)) - (|>> product.right size')) + (|>> product.right ..size')) (def: #export empty? (All [k v] (-> (Dictionary k v) Bit)) @@ -693,6 +693,7 @@ (structure: functor' (All [k] (Functor (Node k))) + (def: (map f fa) (case fa (#Hierarchy size hierarchy) @@ -715,5 +716,6 @@ (structure: #export functor (All [k] (Functor (Dictionary k))) + (def: (map f fa) (update@ #root (:: ..functor' map f) fa))) diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux index 070778080..8e1f83c1c 100644 --- a/stdlib/source/lux/data/collection/list.lux +++ b/stdlib/source/lux/data/collection/list.lux @@ -203,7 +203,7 @@ (#.Some x) (find predicate xs')))) -(def: #export (search check xs) +(def: #export (one check xs) (All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b))) (case xs @@ -216,9 +216,9 @@ (#.Some output) #.None - (search check xs')))) + (one check xs')))) -(def: #export (search-all check xs) +(def: #export (all check xs) (All [a b] (-> (-> a (Maybe b)) (List a) (List b))) (for {## TODO: Stop relying on this ASAP. @@ -239,10 +239,10 @@ (#.Cons x xs') (case (check x) (#.Some output) - (#.Cons output (search-all check xs')) + (#.Cons output (all check xs')) #.None - (search-all check xs'))))) + (all check xs'))))) (def: #export (interpose sep xs) {#.doc "Puts a value between every two elements in the list."} diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index 390f070f0..f59b0808a 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -196,18 +196,22 @@ (text.replace-all "'" "'") (text.replace-all text.double-quote """))) -(def: (write-label [namespace name]) +(def: #export (tag [namespace name]) (-> Tag Text) (case namespace "" name _ ($_ text@compose namespace ..namespace-separator name))) +(def: #export attribute + (-> Attribute Text) + ..tag) + (def: (write-attrs attrs) (-> Attrs Text) (|> attrs dictionary.entries (list@map (function (_ [key value]) - ($_ text@compose (..write-label key) "=" text.double-quote (sanitize-value value) text.double-quote))) + ($_ text@compose (..attribute key) "=" text.double-quote (sanitize-value value) text.double-quote))) (text.join-with " "))) (def: xml-header @@ -223,7 +227,7 @@ (sanitize-value value) (#Node xml-tag xml-attrs xml-children) - (let [tag (..write-label xml-tag) + (let [tag (..tag xml-tag) attrs (if (dictionary.empty? xml-attrs) "" ($_ text@compose " " (write-attrs xml-attrs)))] diff --git a/stdlib/source/lux/macro/template.lux b/stdlib/source/lux/macro/template.lux index 22d8d9251..538aa8442 100644 --- a/stdlib/source/lux/macro/template.lux +++ b/stdlib/source/lux/macro/template.lux @@ -3,8 +3,8 @@ [abstract ["." monad (#+ do)]] [control - ["p" parser ("#@." functor) - ["s" code (#+ Parser)]]] + ["<>" parser ("#@." functor) + ["<.>" code (#+ Parser)]]] [data ["." bit ("#@." codec)] ["." text] @@ -20,13 +20,13 @@ [syntax (#+ syntax:)] ["." code]]) -(syntax: #export (splice {parts (s.tuple (p.some s.any))}) +(syntax: #export (splice {parts (<code>.tuple (<>.some <code>.any))}) (wrap parts)) -(syntax: #export (count {parts (s.tuple (p.some s.any))}) +(syntax: #export (count {parts (<code>.tuple (<>.some <code>.any))}) (wrap (list (code.nat (list.size parts))))) -(syntax: #export (with-locals {locals (s.tuple (p.some s.local-identifier))} +(syntax: #export (with-locals {locals (<code>.tuple (<>.some <code>.local-identifier))} body) (do {@ meta.monad} [g!locals (|> locals @@ -38,35 +38,52 @@ list@join))] (~ body))))))) -(def: snippet - (Parser Text) - ($_ p.either - s.text - s.local-identifier - s.local-tag - (p@map bit@encode s.bit) - (p@map nat@encode s.nat) - (p@map int@encode s.int) - (p@map rev@encode s.rev) - (p@map frac@encode s.frac) - )) +(def: (name-side module-side? parser) + (-> Bit (Parser Name) (Parser Text)) + (do <>.monad + [[module short] parser] + (wrap (if module-side? + module + short)))) -(def: part - (Parser (List Text)) - (s.tuple (p.many ..snippet))) +(def: (snippet module-side?) + (-> Bit (Parser Text)) + (let [full-identifier (..name-side module-side? <code>.identifier) + full-tag (..name-side module-side? <code>.tag)] + ($_ <>.either + <code>.text + (if module-side? + full-identifier + (<>.either <code>.local-identifier + full-identifier)) + (if module-side? + full-tag + (<>.either <code>.local-tag + full-tag)) + (<>@map bit@encode <code>.bit) + (<>@map nat@encode <code>.nat) + (<>@map int@encode <code>.int) + (<>@map rev@encode <code>.rev) + (<>@map frac@encode <code>.frac) + ))) -(syntax: #export (text {simple ..part}) +(def: (part module-side?) + (-> Bit (Parser (List Text))) + (<code>.tuple (<>.many (..snippet module-side?)))) + +(syntax: #export (text {simple (..part false)}) (wrap (list (|> simple (text.join-with "") code.text)))) (template [<name> <simple> <complex>] - [(syntax: #export (<name> {simple ..part} {complex (p.maybe ..part)}) - (case complex - #.None - (wrap (list (|> simple (text.join-with "") <simple>))) - - (#.Some complex) + [(syntax: #export (<name> {name (<>.or (<>.and (..part true) (..part false)) + (..part false))}) + (case name + (#.Left [simple complex]) (wrap (list (<complex> [(text.join-with "" simple) - (text.join-with "" complex)])))))] + (text.join-with "" complex)]))) + + (#.Right simple) + (wrap (list (|> simple (text.join-with "") <simple>)))))] [identifier code.local-identifier code.identifier] [tag code.local-tag code.tag] diff --git a/stdlib/source/lux/meta.lux b/stdlib/source/lux/meta.lux index 6991ec840..e94aa1578 100644 --- a/stdlib/source/lux/meta.lux +++ b/stdlib/source/lux/meta.lux @@ -508,13 +508,13 @@ {#.doc "The entire list of definitions in a module (including the non-exported/private ones)."} (-> Text (Meta (List [Text Definition]))) (:: ..monad map - (list.search-all (function (_ [name global]) - (case global - (#.Left de-aliased) - #.None - - (#.Right definition) - (#.Some [name definition])))) + (list.all (function (_ [name global]) + (case global + (#.Left de-aliased) + #.None + + (#.Right definition) + (#.Some [name definition])))) (..globals module))) (def: #export (exports module-name) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux index 3517a261c..46cfd01e6 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -1238,12 +1238,12 @@ (|>> #Pass) (|>> #Hint)) (method-signature method-style method)))))))] - (case (list.search-all pass! candidates) + (case (list.all pass! candidates) (#.Cons method #.Nil) (wrap method) #.Nil - (/////analysis.throw ..no-candidates [class-name method-name inputsJT (list.search-all hint! candidates)]) + (/////analysis.throw ..no-candidates [class-name method-name inputsJT (list.all hint! candidates)]) candidates (/////analysis.throw ..too-many-candidates [class-name method-name inputsJT candidates])))) @@ -1267,12 +1267,12 @@ (:: @ map (if passes? (|>> #Pass) (|>> #Hint)) (constructor-signature constructor))))))] - (case (list.search-all pass! candidates) + (case (list.all pass! candidates) (#.Cons constructor #.Nil) (wrap constructor) #.Nil - (/////analysis.throw ..no-candidates [class-name ..constructor-method inputsJT (list.search-all hint! candidates)]) + (/////analysis.throw ..no-candidates [class-name ..constructor-method inputsJT (list.all hint! candidates)]) candidates (/////analysis.throw ..too-many-candidates [class-name ..constructor-method inputsJT candidates])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/program.lux b/stdlib/source/lux/tool/compiler/language/lux/program.lux index 6e5c93edf..aef6fdab6 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/program.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/program.lux @@ -42,11 +42,11 @@ [id (archive.id module archive) [descriptor document] (archive.find module archive)] (wrap [[module id] (get@ #descriptor.registry descriptor)])))))] - (case (list.search (function (_ [[module module-id] registry]) - (do maybe.monad - [program-id (artifact.remember ..name registry)] - (wrap [module-id program-id]))) - registries) + (case (list.one (function (_ [[module module-id] registry]) + (do maybe.monad + [program-id (artifact.remember ..name registry)] + (wrap [module-id program-id]))) + registries) (#.Some program-context) (wrap program-context) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux index 172bb4d13..7ac12f55e 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive.lux @@ -152,10 +152,10 @@ (|>> :representation (get@ #resolver) dictionary.entries - (list.search-all (function (_ [module [id descriptor+document]]) - (case descriptor+document - (#.Some _) (#.Some module) - #.None #.None))))) + (list.all (function (_ [module [id descriptor+document]]) + (case descriptor+document + (#.Some _) (#.Some module) + #.None #.None))))) (def: #export (reserved? archive module) (-> Archive Module Bit) @@ -221,10 +221,10 @@ (let [(^slots [#..next #..resolver]) (:representation archive)] (|> resolver dictionary.entries - (list.search-all (function (_ [module [id descriptor+document]]) - (case descriptor+document - (#.Some _) (#.Some [module id]) - #.None #.None))) + (list.all (function (_ [module [id descriptor+document]]) + (case descriptor+document + (#.Some _) (#.Some [module id]) + #.None #.None))) [version next] (binary.run ..writer)))) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux index 4a9d8605b..1619794d1 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux @@ -80,9 +80,9 @@ :representation (get@ #artifacts) row.to-list - (list.search-all (|>> (get@ #category) - (case> (<tag> name) (#.Some name) - _ #.None)))))] + (list.all (|>> (get@ #category) + (case> (<tag> name) (#.Some name) + _ #.None)))))] [#Definition definition definitions] [#Analyser analyser analysers] diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux index 216295d3f..9e83cc367 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux @@ -359,10 +359,10 @@ (def: initial-purge (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module)]]]]) Purge) - (|>> (list.search-all (function (_ [valid-cache? [module-name [module-id _]]]) - (if valid-cache? - #.None - (#.Some [module-name module-id])))) + (|>> (list.all (function (_ [valid-cache? [module-name [module-id _]]]) + (if valid-cache? + #.None + (#.Some [module-name module-id])))) (dictionary.from-list text.hash))) (def: (full-purge caches load-order) diff --git a/stdlib/source/program/aedifex.lux b/stdlib/source/program/aedifex.lux index c2fa69e11..f23ac26da 100644 --- a/stdlib/source/program/aedifex.lux +++ b/stdlib/source/program/aedifex.lux @@ -37,7 +37,8 @@ ["#." pom] ["#." cli] ["#." local] - ["#." dependency] + ["#." dependency #_ + ["#" resolution]] [command ["#." build] ["#." test] @@ -68,7 +69,7 @@ (-> Path /.Profile (IO (Try Any))) (do (try.with io.monad) [file (!.use (:: file.system file) [path]) - pom (:: io.monad wrap (/pom.project profile))] + pom (:: io.monad wrap (/pom.write profile))] (|> pom (:: xml.codec encode) encoding.to-utf8 diff --git a/stdlib/source/program/aedifex/artifact.lux b/stdlib/source/program/aedifex/artifact.lux index 47a9027d0..dc0892eb1 100644 --- a/stdlib/source/program/aedifex/artifact.lux +++ b/stdlib/source/program/aedifex/artifact.lux @@ -5,7 +5,7 @@ ["." hash (#+ Hash)]] [data ["." text - ["%" format (#+ format)]] + ["%" format (#+ Format)]] [collection ["." list ("#@." monoid)]]] [world @@ -42,31 +42,41 @@ text.hash )) -(def: group-separator - ".") +(template [<separator> <definition>] + [(def: <definition> + Text + <separator>)] -(def: version-separator - "-") + ["." group-separator] + ["-" version-separator] + [":" identity-separator] + ) (def: #export (identity artifact) (-> Artifact Text) - (format (get@ #name artifact) - ..version-separator - (get@ #version artifact))) + (%.format (get@ #name artifact) + ..version-separator + (get@ #version artifact))) + +(def: #export (format value) + (Format Artifact) + (%.format (get@ #group value) + ..identity-separator + (..identity value))) (def: #export (path artifact) (-> Artifact Text) - (let [directory (format (|> artifact - (get@ #group) - (text.split-all-with ..group-separator) - (text.join-with uri.separator)) - uri.separator - (get@ #name artifact) - uri.separator - (get@ #version artifact))] - (format directory - uri.separator - (..identity artifact)))) + (let [directory (%.format (|> artifact + (get@ #group) + (text.split-all-with ..group-separator) + (text.join-with uri.separator)) + uri.separator + (get@ #name artifact) + uri.separator + (get@ #version artifact))] + (%.format directory + uri.separator + (..identity artifact)))) (def: #export (local artifact) (-> Artifact (List Text)) diff --git a/stdlib/source/program/aedifex/artifact/extension.lux b/stdlib/source/program/aedifex/artifact/extension.lux index 04d40fec4..412bf699a 100644 --- a/stdlib/source/program/aedifex/artifact/extension.lux +++ b/stdlib/source/program/aedifex/artifact/extension.lux @@ -2,7 +2,9 @@ [lux #* [data [text - ["%" format (#+ format)]]]] + ["%" format (#+ format)]]] + [macro + ["." template]]] ["." // #_ ["#" type]]) @@ -16,22 +18,14 @@ (-> //.Type Extension) (|>> (format ..separator))) -(def: #export lux-library - Extension - (..extension //.lux-library)) - -(def: #export jvm-library - Extension - (..extension //.jvm-library)) - -(def: #export pom - Extension - (..extension //.pom)) - -(def: #export sha1 - Extension - (format ..separator "sha1")) - -(def: #export md5 - Extension - (format ..separator "md5")) +(template [<name>] + [(def: #export <name> + Extension + (..extension (template.identifier [//._] [<name>])))] + + [lux-library] + [jvm-library] + [pom] + [sha1] + [md5] + ) diff --git a/stdlib/source/program/aedifex/artifact/type.lux b/stdlib/source/program/aedifex/artifact/type.lux index e5836d13f..35035ebc4 100644 --- a/stdlib/source/program/aedifex/artifact/type.lux +++ b/stdlib/source/program/aedifex/artifact/type.lux @@ -13,4 +13,6 @@ ["tar" lux-library] ["jar" jvm-library] ["pom" pom] + ["sha1" sha1] + ["md5" md5] ) diff --git a/stdlib/source/program/aedifex/command/build.lux b/stdlib/source/program/aedifex/command/build.lux index 2c4b26aed..6a1ab93d4 100644 --- a/stdlib/source/program/aedifex/command/build.lux +++ b/stdlib/source/program/aedifex/command/build.lux @@ -25,7 +25,8 @@ ["#." action] ["#." command (#+ Command)] ["#." local] - ["#." dependency (#+ Dependency Resolution)] + ["#." dependency (#+ Dependency) + ["#/." resolution (#+ Resolution)]] ["#." shell] ["#." artifact (#+ Group Name Artifact) ["#/." type]]]) @@ -36,11 +37,11 @@ (def: (dependency-finder group name) (-> Group Name Finder) (|>> dictionary.entries - (list.search (function (_ [dependency package]) - (if (and (text@= group (get@ [#///dependency.artifact #///artifact.group] dependency)) - (text@= name (get@ [#///dependency.artifact #///artifact.name] dependency))) - (#.Some dependency) - #.None))))) + (list.one (function (_ [dependency package]) + (if (and (text@= group (get@ [#///dependency.artifact #///artifact.group] dependency)) + (text@= name (get@ [#///dependency.artifact #///artifact.name] dependency))) + (#.Some dependency) + #.None))))) (def: lux-group Group @@ -125,11 +126,11 @@ (do ///action.monad [cache (///local.all-cached (file.async file.system) (set.to-list (get@ #///.dependencies profile)) - ///dependency.empty) + ///dependency/resolution.empty) resolution (promise.future - (///dependency.resolve-all (set.to-list (get@ #///.repositories profile)) - (set.to-list (get@ #///.dependencies profile)) - cache)) + (///dependency/resolution.resolve-all (set.to-list (get@ #///.repositories profile)) + (set.to-list (get@ #///.dependencies profile)) + cache)) _ (///local.cache-all (file.async file.system) resolution) [resolution compiler] (promise@wrap (..compiler resolution)) diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux index b63aa2972..d7c7802b7 100644 --- a/stdlib/source/program/aedifex/command/deploy.lux +++ b/stdlib/source/program/aedifex/command/deploy.lux @@ -28,11 +28,12 @@ ["//" upload (#+ User Password)] ["#." action (#+ Action)] ["#." command (#+ Command)] - ["#." dependency] ["#." pom] ["#." hash] ["#." artifact - ["#/." type]]]) + ["#/." type]] + ["#." dependency + ["#/." resolution]]]) (exception: #export (cannot-find-repository {repository Text} {options (Dictionary Text ///dependency.Repository)}) @@ -66,9 +67,9 @@ [library (:: @ map (binary.run tar.writer) (export.library (file.async file.system) (set.to-list (get@ #/.sources profile)))) - pom (promise@wrap (///pom.project profile)) + pom (promise@wrap (///pom.write profile)) _ (deploy! ///artifact/type.pom (|> pom (:: xml.codec encode) encoding.to-utf8)) _ (deploy! ///artifact/type.lux-library library) - _ (deploy! "sha1" (///hash.data (///hash.sha1 library))) - _ (deploy! "md5" (///hash.data (///hash.md5 library)))] + _ (deploy! ///artifact/type.sha1 (///hash.data (///hash.sha1 library))) + _ (deploy! ///artifact/type.md5 (///hash.data (///hash.md5 library)))] (wrap []))))) diff --git a/stdlib/source/program/aedifex/dependency.lux b/stdlib/source/program/aedifex/dependency.lux index de6a1e4cf..cdd0789ff 100644 --- a/stdlib/source/program/aedifex/dependency.lux +++ b/stdlib/source/program/aedifex/dependency.lux @@ -1,46 +1,22 @@ (.module: - [lux (#- Name) - ["." host (#+ import:)] + [lux (#- Type) [abstract - [codec (#+ Codec)] - [monad (#+ do)] ["." equivalence (#+ Equivalence)] ["." hash (#+ Hash)]] - [control - ["." io (#+ IO)] - ["." try (#+ Try)] - ["." exception (#+ Exception exception:)] - ["<>" parser - ["<xml>" xml (#+ Parser)]]] [data - ["." binary (#+ Binary)] - ["." name] - ["." maybe] - ["." text - ["%" format (#+ format)] - ["." encoding]] - [number - ["." i64] - ["n" nat]] - [format - ["." xml (#+ Tag XML)]] - [collection - ["." dictionary (#+ Dictionary)]]] + ["." text]] [world - [net (#+ URL) - ["." uri]]]] + [net (#+ URL)]]] ["." // #_ - ["#." hash] ["#." artifact (#+ Artifact) - ["#/." type] - ["#/." extension]]]) + [type (#+ Type)]]]) (type: #export Repository URL) (type: #export Dependency {#artifact Artifact - #type //artifact/type.Type}) + #type Type}) (def: #export equivalence (Equivalence Dependency) @@ -55,203 +31,3 @@ //artifact.hash text.hash )) - -(import: java/lang/String) - -(import: java/lang/AutoCloseable - (close [] #io #try void)) - -(import: java/io/InputStream) - -(import: java/net/URL - (new [java/lang/String]) - (openStream [] #io #try java/io/InputStream)) - -(import: java/io/BufferedInputStream - (new [java/io/InputStream]) - (read [[byte] int int] #io #try int)) - -(def: buffer-size - (n.* 512 1,024)) - -(def: (download url) - (-> URL (IO (Try Binary))) - (do {@ (try.with io.monad)} - [input (|> (java/net/URL::new url) - java/net/URL::openStream - (:: @ map (|>> java/io/BufferedInputStream::new))) - #let [buffer (binary.create ..buffer-size)]] - (loop [output (:: binary.monoid identity)] - (do @ - [bytes-read (java/io/BufferedInputStream::read buffer +0 (.int ..buffer-size) input)] - (case bytes-read - -1 (do @ - [_ (java/lang/AutoCloseable::close input)] - (wrap output)) - _ (if (n.= ..buffer-size bytes-read) - (recur (:: binary.monoid compose output buffer)) - (do @ - [chunk (:: io.monad wrap (binary.slice 0 (.nat bytes-read) buffer))] - (recur (:: binary.monoid compose output chunk))))))))) - -(template [<name>] - [(exception: #export (<name> {dependency Dependency} {hash Text}) - (let [artifact (get@ #artifact dependency) - type (get@ #type dependency)] - (exception.report - ["Artifact" (format (get@ #//artifact.group artifact) - " " (get@ #//artifact.name artifact) - " " (get@ #//artifact.version artifact))] - ["Type" (%.text type)] - ["Hash" (%.text hash)])))] - - [sha1-does-not-match] - [md5-does-not-match] - ) - -(type: #export Package - {#library Binary - #pom XML - #dependencies (List Dependency) - #sha1 Text - #md5 Text}) - -(def: (verified-hash dependency library url hash codec exception) - (All [h] - (-> Dependency Binary URL - (-> Binary (//hash.Hash h)) (Codec Text (//hash.Hash h)) - (Exception [Dependency Text]) - (IO (Try Text)))) - (do (try.with io.monad) - [#let [expected (hash library)] - actual (..download url)] - (:: io.monad wrap - (do try.monad - [output (encoding.from-utf8 actual) - actual (:: codec decode output) - _ (exception.assert exception [dependency output] - (:: //hash.equivalence = expected actual))] - (wrap output))))) - -(def: parse-property - (Parser [Tag Text]) - (do <>.monad - [property <xml>.tag - _ (<xml>.node property) - value (<xml>.children <xml>.text)] - (wrap [property value]))) - -(def: parse-dependency - (Parser Dependency) - (do {@ <>.monad} - [properties (:: @ map (dictionary.from-list name.hash) - (<xml>.children (<>.some ..parse-property)))] - (<| <>.lift - try.from-maybe - (do maybe.monad - [group (dictionary.get ["" "groupId"] properties) - artifact (dictionary.get ["" "artifactId"] properties) - version (dictionary.get ["" "version"] properties)] - (wrap {#artifact {#//artifact.group group - #//artifact.name artifact - #//artifact.version version} - #type (|> properties - (dictionary.get ["" "type"]) - (maybe.default //artifact/type.lux-library))}))))) - -(def: parse-dependencies - (Parser (List Dependency)) - (do {@ <>.monad} - [_ (<xml>.node ["" "dependencies"])] - (<xml>.children (<>.some ..parse-dependency)))) - -(def: #export from-pom - (-> XML (Try (List Dependency))) - (<xml>.run (do {@ <>.monad} - [_ (<xml>.node ["" "project"])] - (<xml>.children (loop [_ []] - (do @ - [?dependencies (<>.or ..parse-dependencies - (<>.maybe <xml>.ignore))] - (case ?dependencies - (#.Left dependencies) - (wrap dependencies) - - (#.Right #.None) - (wrap (: (List Dependency) - (list))) - - (#.Right (#.Some _)) - (recur [])))))))) - -(def: #export (resolve repository dependency) - (-> Repository Dependency (IO (Try Package))) - (let [[artifact type] dependency - prefix (format repository uri.separator (//artifact.path artifact))] - (do (try.with io.monad) - [library (..download (format prefix (//artifact/extension.extension type))) - sha1 (..verified-hash dependency library (format prefix //artifact/extension.sha1) //hash.sha1 //hash.sha1-codec ..sha1-does-not-match) - md5 (..verified-hash dependency library (format prefix //artifact/extension.md5) //hash.md5 //hash.md5-codec ..md5-does-not-match) - pom (..download (format prefix //artifact/extension.pom))] - (:: io.monad wrap - (do try.monad - [pom (encoding.from-utf8 pom) - pom (:: xml.codec decode pom) - dependencies (..from-pom pom)] - (wrap {#library library - #pom pom - #dependencies dependencies - #sha1 sha1 - #md5 md5})))))) - -(type: #export Resolution - (Dictionary Dependency Package)) - -(def: #export empty - Resolution - (dictionary.new ..hash)) - -(exception: #export (cannot-resolve {dependency Dependency}) - (let [artifact (get@ #artifact dependency) - type (get@ #type dependency)] - (exception.report - ["Artifact" (format (get@ #//artifact.group artifact) - " " (get@ #//artifact.name artifact) - " " (get@ #//artifact.version artifact))] - ["Type" (%.text type)]))) - -(def: (resolve-any repositories dependency) - (-> (List Repository) Dependency (IO (Try Package))) - (case repositories - #.Nil - (|> dependency - (exception.throw ..cannot-resolve) - (:: io.monad wrap)) - - (#.Cons repository alternatives) - (do io.monad - [outcome (..resolve repository dependency)] - (case outcome - (#try.Success package) - (wrap outcome) - - (#try.Failure error) - (resolve-any alternatives dependency))))) - -(def: #export (resolve-all repositories dependencies resolution) - (-> (List Repository) (List Dependency) Resolution (IO (Try Resolution))) - (case dependencies - #.Nil - (:: (try.with io.monad) wrap resolution) - - (#.Cons head tail) - (do (try.with io.monad) - [package (case (dictionary.get head resolution) - (#.Some package) - (wrap package) - - #.None - (..resolve-any repositories head)) - #let [resolution (dictionary.put head package resolution)] - resolution (resolve-all repositories (get@ #dependencies package) resolution)] - (resolve-all repositories tail resolution)))) diff --git a/stdlib/source/program/aedifex/dependency/resolution.lux b/stdlib/source/program/aedifex/dependency/resolution.lux new file mode 100644 index 000000000..57df92d2a --- /dev/null +++ b/stdlib/source/program/aedifex/dependency/resolution.lux @@ -0,0 +1,184 @@ +(.module: + [lux (#- Name) + ["." host (#+ import:)] + [abstract + [codec (#+ Codec)] + [monad (#+ do)]] + [control + ["." io (#+ IO)] + ["." try (#+ Try)] + ["." exception (#+ Exception exception:)] + ["<>" parser + ["<.>" xml (#+ Parser)]]] + [data + ["." binary (#+ Binary)] + ["." name] + ["." maybe] + [text + ["%" format (#+ format)] + ["." encoding]] + [number + ["." i64] + ["n" nat]] + [format + ["." xml (#+ Tag XML)]] + [collection + ["." dictionary (#+ Dictionary)] + ["." set]]] + [world + [net (#+ URL) + ["." uri]]]] + ["." // (#+ Repository Dependency) + ["/#" // #_ + ["/" profile] + ["#." hash] + ["#." pom] + ["#." artifact + ["#/." extension]]]]) + +(import: java/lang/String) + +(import: java/lang/AutoCloseable + (close [] #io #try void)) + +(import: java/io/InputStream) + +(import: java/net/URL + (new [java/lang/String]) + (openStream [] #io #try java/io/InputStream)) + +(import: java/io/BufferedInputStream + (new [java/io/InputStream]) + (read [[byte] int int] #io #try int)) + +(def: buffer-size + (n.* 512 1,024)) + +(def: (download url) + (-> URL (IO (Try Binary))) + (do {@ (try.with io.monad)} + [input (|> (java/net/URL::new url) + java/net/URL::openStream + (:: @ map (|>> java/io/BufferedInputStream::new))) + #let [buffer (binary.create ..buffer-size)]] + (loop [output (:: binary.monoid identity)] + (do @ + [bytes-read (java/io/BufferedInputStream::read buffer +0 (.int ..buffer-size) input)] + (case bytes-read + -1 (do @ + [_ (java/lang/AutoCloseable::close input)] + (wrap output)) + _ (if (n.= ..buffer-size bytes-read) + (recur (:: binary.monoid compose output buffer)) + (do @ + [chunk (:: io.monad wrap (binary.slice 0 (.nat bytes-read) buffer))] + (recur (:: binary.monoid compose output chunk))))))))) + +(template [<name>] + [(exception: #export (<name> {dependency Dependency} {hash Text}) + (let [artifact (get@ #//.artifact dependency) + type (get@ #//.type dependency)] + (exception.report + ["Artifact" (format (get@ #///artifact.group artifact) + " " (get@ #///artifact.name artifact) + " " (get@ #///artifact.version artifact))] + ["Type" (%.text type)] + ["Hash" (%.text hash)])))] + + [sha1-does-not-match] + [md5-does-not-match] + ) + +(type: #export Package + {#library Binary + #pom XML + #dependencies (List Dependency) + #sha1 Text + #md5 Text}) + +(def: (verified-hash dependency library url hash codec exception) + (All [h] + (-> Dependency Binary URL + (-> Binary (///hash.Hash h)) (Codec Text (///hash.Hash h)) + (Exception [Dependency Text]) + (IO (Try Text)))) + (do (try.with io.monad) + [#let [expected (hash library)] + actual (..download url)] + (:: io.monad wrap + (do try.monad + [output (encoding.from-utf8 actual) + actual (:: codec decode output) + _ (exception.assert exception [dependency output] + (:: ///hash.equivalence = expected actual))] + (wrap output))))) + +(def: #export (resolve repository dependency) + (-> Repository Dependency (IO (Try Package))) + (let [[artifact type] dependency + prefix (format repository uri.separator (///artifact.path artifact))] + (do (try.with io.monad) + [library (..download (format prefix (///artifact/extension.extension type))) + sha1 (..verified-hash dependency library (format prefix ///artifact/extension.sha1) ///hash.sha1 ///hash.sha1-codec ..sha1-does-not-match) + md5 (..verified-hash dependency library (format prefix ///artifact/extension.md5) ///hash.md5 ///hash.md5-codec ..md5-does-not-match) + pom (..download (format prefix ///artifact/extension.pom))] + (:: io.monad wrap + (do try.monad + [pom (encoding.from-utf8 pom) + pom (:: xml.codec decode pom) + profile (<xml>.run ///pom.parser pom)] + (wrap {#library library + #pom pom + #dependencies (set.to-list (get@ #/.dependencies profile)) + #sha1 sha1 + #md5 md5})))))) + +(type: #export Resolution + (Dictionary Dependency Package)) + +(def: #export empty + Resolution + (dictionary.new //.hash)) + +(exception: #export (cannot-resolve {dependency Dependency}) + (let [artifact (get@ #//.artifact dependency) + type (get@ #//.type dependency)] + (exception.report + ["Artifact" (%.text (///artifact.format artifact))] + ["Type" (%.text type)]))) + +(def: (resolve-any repositories dependency) + (-> (List Repository) Dependency (IO (Try Package))) + (case repositories + #.Nil + (|> dependency + (exception.throw ..cannot-resolve) + (:: io.monad wrap)) + + (#.Cons repository alternatives) + (do io.monad + [outcome (..resolve repository dependency)] + (case outcome + (#try.Success package) + (wrap outcome) + + (#try.Failure error) + (resolve-any alternatives dependency))))) + +(def: #export (resolve-all repositories dependencies resolution) + (-> (List Repository) (List Dependency) Resolution (IO (Try Resolution))) + (case dependencies + #.Nil + (:: (try.with io.monad) wrap resolution) + + (#.Cons head tail) + (do (try.with io.monad) + [package (case (dictionary.get head resolution) + (#.Some package) + (wrap package) + + #.None + (..resolve-any repositories head)) + #let [resolution (dictionary.put head package resolution)] + resolution (resolve-all repositories (get@ #dependencies package) resolution)] + (resolve-all repositories tail resolution)))) diff --git a/stdlib/source/program/aedifex/local.lux b/stdlib/source/program/aedifex/local.lux index 626996ef3..bc2dbfb91 100644 --- a/stdlib/source/program/aedifex/local.lux +++ b/stdlib/source/program/aedifex/local.lux @@ -9,7 +9,9 @@ [concurrency ["." promise (#+ Promise)]] [security - ["!" capability]]] + ["!" capability]] + ["<>" parser + ["<.>" xml]]] [data [binary (#+ Binary)] ["." text @@ -31,11 +33,12 @@ ["." // #_ ["/" profile (#+ Profile)] ["#." pom] - ["#." dependency (#+ Package Resolution Dependency)] ["#." hash] ["#." artifact (#+ Artifact) ["#/." type] - ["#/." extension]]]) + ["#/." extension]] + ["#." dependency (#+ Dependency) + ["#/." resolution (#+ Package Resolution)]]]) (def: (local system) (All [a] (-> (file.System a) Path)) @@ -80,7 +83,7 @@ package (export.library system (set.to-list (get@ #/.sources profile))) _ (..save! system (binary.run tar.writer package) (format artifact-name //artifact/extension.lux-library)) - pom (:: promise.monad wrap (//pom.project profile))] + pom (:: promise.monad wrap (//pom.write profile))] (..save! system (|> pom (:: xml.codec encode) encoding.to-utf8) (format artifact-name //artifact/extension.pom))) @@ -95,16 +98,16 @@ directory (: (Promise (Try (Directory Promise))) (file.get-directory promise.monad system directory)) _ (..save! system - (get@ #//dependency.library package) + (get@ #//dependency/resolution.library package) (format prefix (//artifact/extension.extension type))) _ (..save! system - (encoding.to-utf8 (get@ #//dependency.sha1 package)) + (encoding.to-utf8 (get@ #//dependency/resolution.sha1 package)) (format prefix //artifact/extension.sha1)) _ (..save! system - (encoding.to-utf8 (get@ #//dependency.md5 package)) + (encoding.to-utf8 (get@ #//dependency/resolution.md5 package)) (format prefix //artifact/extension.md5)) _ (..save! system - (|> package (get@ #//dependency.pom) (:: xml.codec encode) encoding.to-utf8) + (|> package (get@ #//dependency/resolution.pom) (:: xml.codec encode) encoding.to-utf8) (format prefix //artifact/extension.pom))] (wrap []))) @@ -133,20 +136,20 @@ (do try.monad [pom (encoding.from-utf8 pom) pom (:: xml.codec decode pom) - dependencies (//dependency.from-pom pom)] - (wrap [pom dependencies]))) + profile (<xml>.run //pom.parser pom)] + (wrap [pom (set.to-list (get@ #/.dependencies profile))]))) library (..read! system (format prefix (//artifact/extension.extension type))) sha1 (..read! system (format prefix //artifact/extension.sha1)) md5 (..read! system (format prefix //artifact/extension.md5))] - (wrap {#//dependency.library library - #//dependency.pom pom - #//dependency.dependencies dependencies - #//dependency.sha1 (|> sha1 - (:coerce (//hash.Hash //hash.SHA-1)) - (:: //hash.sha1-codec encode)) - #//dependency.md5 (|> md5 - (:coerce (//hash.Hash //hash.MD5)) - (:: //hash.md5-codec encode))}))) + (wrap {#//dependency/resolution.library library + #//dependency/resolution.pom pom + #//dependency/resolution.dependencies dependencies + #//dependency/resolution.sha1 (|> sha1 + (:coerce (//hash.Hash //hash.SHA-1)) + (:: //hash.sha1-codec encode)) + #//dependency/resolution.md5 (|> md5 + (:coerce (//hash.Hash //hash.MD5)) + (:: //hash.md5-codec encode))}))) (def: #export (all-cached system dependencies resolution) (-> (file.System Promise) (List Dependency) Resolution (Promise (Try Resolution))) @@ -167,7 +170,7 @@ (#try.Success package) (let [resolution (dictionary.put head package resolution)] (do (try.with promise.monad) - [resolution (all-cached system (get@ #//dependency.dependencies package) resolution)] + [resolution (all-cached system (get@ #//dependency/resolution.dependencies package) resolution)] <next>)) (#try.Failure error) diff --git a/stdlib/source/program/aedifex/pom.lux b/stdlib/source/program/aedifex/pom.lux index 9370620f5..4f7d8a4fd 100644 --- a/stdlib/source/program/aedifex/pom.lux +++ b/stdlib/source/program/aedifex/pom.lux @@ -1,23 +1,36 @@ (.module: [lux #* + [abstract + [monad (#+ do)]] [control [pipe (#+ case>)] ["." try (#+ Try)] - ["." exception]] + ["." exception] + ["<>" parser + ["<xml>" xml (#+ Parser)]]] [data + ["." name] ["." maybe ("#@." functor)] [format - ["_" xml (#+ XML)]] + ["_" xml (#+ Tag XML)]] [collection - ["." list ("#@." monoid functor)] - ["." set]]]] + ["." list ("#@." monoid functor fold)] + ["." set] + ["." dictionary]]]] ["." // #_ ["/" profile] - ["#." artifact (#+ Artifact)] - ["#." dependency (#+ Repository Dependency)]]) + ["#." dependency (#+ Repository Dependency)] + ["#." artifact (#+ Artifact) + ["#/." type]]]) ## https://maven.apache.org/pom.html +(def: project-tag "project") +(def: dependencies-tag "dependencies") +(def: group-tag "groupId") +(def: artifact-tag "artifactId") +(def: version-tag "version") + (def: #export file "pom.xml") @@ -34,9 +47,9 @@ (def: (artifact value) (-> Artifact (List XML)) - (list (..property "groupId" (get@ #//artifact.group value)) - (..property "artifactId" (get@ #//artifact.name value)) - (..property "version" (get@ #//artifact.version value)))) + (list (..property ..group-tag (get@ #//artifact.group value)) + (..property ..artifact-tag (get@ #//artifact.name value)) + (..property ..version-tag (get@ #//artifact.version value)))) (def: distribution (-> /.Distribution XML) @@ -64,66 +77,109 @@ (list@compose (..artifact (get@ #//dependency.artifact value)) (list (..property "type" (get@ #//dependency.type value)))))) -(def: scm - (-> /.SCM XML) - (|>> (..property "url") - list - (#_.Node ["" "scm"] _.attrs))) - -(def: (organization [name url]) - (-> /.Organization XML) - (|> (list (..property "name" name) - (..property "url" url)) - (#_.Node ["" "organization"] _.attrs))) - -(def: (developer-organization [name url]) - (-> /.Organization (List XML)) - (list (..property "organization" name) - (..property "organizationUrl" url))) - -(def: (developer' [name email organization]) - (-> /.Developer (List XML)) - (list& (..property "name" name) - (..property "email" email) - (|> organization (maybe@map ..developer-organization) (maybe.default (list))))) - -(template [<name> <type> <tag>] - [(def: <name> - (-> <type> XML) - (|>> ..developer' (#_.Node ["" <tag>] _.attrs)))] - - [developer /.Developer "developer"] - [contributor /.Contributor "contributor"] - ) - (def: (group tag) (-> Text (-> (List XML) XML)) (|>> (#_.Node ["" tag] _.attrs))) -(def: (info value) - (-> /.Info (List XML)) - ($_ list@compose - (|> value (get@ #/.url) (maybe@map (..property "url")) maybe.to-list) - (|> value (get@ #/.description) (maybe@map (..property "description")) maybe.to-list) - (|> value (get@ #/.licenses) (list@map ..license) (..group "licenses") list) - (|> value (get@ #/.scm) (maybe@map ..scm) maybe.to-list) - (|> value (get@ #/.organization) (maybe@map ..organization) maybe.to-list) - (|> value (get@ #/.developers) (list@map ..developer) (..group "developers") list) - (|> value (get@ #/.contributors) (list@map ..contributor) (..group "contributors") list) - )) - -(def: #export (project value) +(comment + (def: scm + (-> /.SCM XML) + (|>> (..property "url") + list + (#_.Node ["" "scm"] _.attrs))) + + (def: (organization [name url]) + (-> /.Organization XML) + (|> (list (..property "name" name) + (..property "url" url)) + (#_.Node ["" "organization"] _.attrs))) + + (def: (developer-organization [name url]) + (-> /.Organization (List XML)) + (list (..property "organization" name) + (..property "organizationUrl" url))) + + (def: (developer' [name email organization]) + (-> /.Developer (List XML)) + (list& (..property "name" name) + (..property "email" email) + (|> organization (maybe@map ..developer-organization) (maybe.default (list))))) + + (template [<name> <type> <tag>] + [(def: <name> + (-> <type> XML) + (|>> ..developer' (#_.Node ["" <tag>] _.attrs)))] + + [developer /.Developer "developer"] + [contributor /.Contributor "contributor"] + ) + + (def: (info value) + (-> /.Info (List XML)) + ($_ list@compose + (|> value (get@ #/.url) (maybe@map (..property "url")) maybe.to-list) + (|> value (get@ #/.description) (maybe@map (..property "description")) maybe.to-list) + (|> value (get@ #/.licenses) (list@map ..license) (..group "licenses") list) + (|> value (get@ #/.scm) (maybe@map ..scm) maybe.to-list) + (|> value (get@ #/.organization) (maybe@map ..organization) maybe.to-list) + (|> value (get@ #/.developers) (list@map ..developer) (..group "developers") list) + (|> value (get@ #/.contributors) (list@map ..contributor) (..group "contributors") list) + )) + ) + +(def: #export (write value) (-> /.Profile (Try XML)) (case (get@ #/.identity value) (#.Some identity) (#try.Success - (#_.Node ["" "project"] _.attrs + (#_.Node ["" ..project-tag] _.attrs ($_ list@compose (list ..version) (..artifact identity) (|> value (get@ #/.repositories) set.to-list (list@map ..repository) (..group "repositories") list) - (|> value (get@ #/.dependencies) set.to-list (list@map ..dependency) (..group "dependencies") list) + (|> value (get@ #/.dependencies) set.to-list (list@map ..dependency) (..group ..dependencies-tag) list) ))) _ (exception.throw /.no-identity []))) + +(def: parse-property + (Parser [Tag Text]) + (<>.and <xml>.tag + (<xml>.children <xml>.text))) + +(def: parse-dependency + (Parser Dependency) + (do {@ <>.monad} + [properties (:: @ map (dictionary.from-list name.hash) + (<xml>.children (<>.some ..parse-property)))] + (<| <>.lift + try.from-maybe + (do maybe.monad + [group (dictionary.get ["" ..group-tag] properties) + artifact (dictionary.get ["" ..artifact-tag] properties) + version (dictionary.get ["" ..version-tag] properties)] + (wrap {#//dependency.artifact {#//artifact.group group + #//artifact.name artifact + #//artifact.version version} + #//dependency.type (|> properties + (dictionary.get ["" "type"]) + (maybe.default //artifact/type.lux-library))}))))) + +(def: parse-dependencies + (Parser (List Dependency)) + (do {@ <>.monad} + [_ (<xml>.node ["" ..dependencies-tag])] + (<xml>.children (<>.some ..parse-dependency)))) + +(def: #export parser + (Parser /.Profile) + (do {@ <>.monad} + [_ (<xml>.node ["" ..project-tag])] + (<xml>.children + (do @ + [dependencies (<xml>.somewhere ..parse-dependencies) + _ (<>.some <xml>.ignore)] + (wrap (|> (:: /.monoid identity) + (update@ #/.dependencies (function (_ empty) + (list@fold set.add empty dependencies))))))))) diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux index c496eb88b..b5aa7e34e 100644 --- a/stdlib/source/test/aedifex.lux +++ b/stdlib/source/test/aedifex.lux @@ -7,6 +7,7 @@ [cli (#+ program:)]]]] ["." / #_ ["#." artifact] + ["#." dependency] ["#." profile] ["#." project] ["#." cli] @@ -17,6 +18,7 @@ Test ($_ _.and /artifact.test + /dependency.test /profile.test /project.test /cli.test diff --git a/stdlib/source/test/aedifex/artifact/type.lux b/stdlib/source/test/aedifex/artifact/type.lux index fd815f19e..cbc6f681b 100644 --- a/stdlib/source/test/aedifex/artifact/type.lux +++ b/stdlib/source/test/aedifex/artifact/type.lux @@ -20,8 +20,10 @@ (<| (_.covering /._) (_.with-cover [/.Type] ($_ _.and - (_.cover [/.lux-library /.jvm-library /.pom] - (let [options (list /.lux-library /.jvm-library /.pom) + (_.cover [/.lux-library /.jvm-library + /.pom /.md5 /.sha1] + (let [options (list /.lux-library /.jvm-library + /.pom /.md5 /.sha1) uniques (set.from-list text.hash options)] (n.= (list.size options) (set.size uniques)))) diff --git a/stdlib/source/test/aedifex/dependency.lux b/stdlib/source/test/aedifex/dependency.lux new file mode 100644 index 000000000..e7388189c --- /dev/null +++ b/stdlib/source/test/aedifex/dependency.lux @@ -0,0 +1,29 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence]]}] + [math + ["." random (#+ Random)]]] + [// + ["@." artifact]] + {#program + ["." /]}) + +(def: #export random + (Random /.Dependency) + ($_ random.and + @artifact.random + (random.ascii/alpha 1))) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Dependency] + ($_ _.and + (_.with-cover [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + )))) diff --git a/stdlib/source/test/aedifex/profile.lux b/stdlib/source/test/aedifex/profile.lux index 94f695a9b..398a85f5b 100644 --- a/stdlib/source/test/aedifex/profile.lux +++ b/stdlib/source/test/aedifex/profile.lux @@ -23,7 +23,8 @@ [math ["." random (#+ Random) ("#@." monad)]]] [// - ["@." artifact]] + ["@." artifact] + ["@." dependency]] {#program ["." / ["/#" // #_ @@ -105,12 +106,6 @@ (Random Repository) (random.ascii/alpha 1)) -(def: dependency - (Random Dependency) - ($_ random.and - @artifact.random - (random.ascii/alpha 1))) - (def: source (Random /.Source) (random.ascii/alpha 1)) @@ -126,7 +121,7 @@ (random.maybe @artifact.random) (random.maybe ..info) (..set-of text.hash ..repository) - (..set-of //dependency.hash ..dependency) + (..set-of //dependency.hash @dependency.random) (..set-of text.hash ..source) (random.maybe ..target) (random.maybe (random.ascii/alpha 1)) diff --git a/stdlib/source/test/lux/control/parser/xml.lux b/stdlib/source/test/lux/control/parser/xml.lux index 15e0e993b..b46994c97 100644 --- a/stdlib/source/test/lux/control/parser/xml.lux +++ b/stdlib/source/test/lux/control/parser/xml.lux @@ -86,10 +86,10 @@ [expected-tag ..random-tag expected-attribute ..random-attribute expected-value (random.ascii/alpha 1)] - (_.cover [/.attr] + (_.cover [/.attribute] (|> (/.run (do //.monad [_ (/.node expected-tag) - _ (/.attr expected-attribute)] + _ (/.attribute expected-attribute)] /.ignore) (#xml.Node expected-tag (|> (dictionary.new name.hash) @@ -98,7 +98,7 @@ (!expect (#try.Success []))))) (!failure /.unknown-attribute [[(do //.monad - [_ (/.attr ["" expected])] + [_ (/.attribute ["" expected])] /.ignore) (#xml.Node [expected expected] (|> (dictionary.new name.hash) @@ -158,7 +158,7 @@ /.ignore) (#xml.Text expected)] [(do //.monad - [_ (/.attr [expected expected])] + [_ (/.attribute [expected expected])] /.ignore) (#xml.Text expected)] [(do {@ //.monad} diff --git a/stdlib/source/test/lux/data/collection/dictionary.lux b/stdlib/source/test/lux/data/collection/dictionary.lux index fca670802..b2956fa85 100644 --- a/stdlib/source/test/lux/data/collection/dictionary.lux +++ b/stdlib/source/test/lux/data/collection/dictionary.lux @@ -1,16 +1,16 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract [monad (#+ do)] - ["eq" equivalence] + ["." equivalence] {[0 #spec] [/ ["$." equivalence] ["$." functor (#+ Injection)]]}] [control - ["." try]] + ["." try] + ["." exception]] [data ["." maybe] [number @@ -18,7 +18,7 @@ [collection ["." list ("#@." functor)]]] [math - ["r" random]]] + ["." random]]] {1 ["." /]}) @@ -26,111 +26,190 @@ (Injection (/.Dictionary Nat)) (|>> [0] list (/.from-list n.hash))) -(def: #export test +(def: for-dictionaries Test - (<| (_.context (%.name (name-of /.Dictionary))) - (do r.monad - [#let [capped-nat (:: r.monad map (n.% 100) r.nat)] - size capped-nat - dict (r.dictionary n.hash size r.nat capped-nat) - non-key (|> r.nat (r.filter (function (_ key) (not (/.contains? key dict))))) - test-val (|> r.nat (r.filter (function (_ val) (not (list.member? n.equivalence (/.values dict) val)))))] - ($_ _.and - ($equivalence.spec (/.equivalence n.equivalence) - (r.dictionary n.hash size r.nat r.nat)) - ($functor.spec ..injection /.equivalence /.functor) - - (_.test "Size function should correctly represent Dictionary size." - (n.= size (/.size dict))) - (_.test "Dictionaries of size 0 should be considered empty." - (if (n.= 0 size) - (/.empty? dict) - (not (/.empty? dict)))) - (_.test "The functions 'entries', 'keys' and 'values' should be synchronized." - (:: (list.equivalence (eq.product n.equivalence n.equivalence)) = - (/.entries dict) - (list.zip2 (/.keys dict) - (/.values dict)))) - (_.test "Dictionary should be able to recognize it's own keys." - (list.every? (function (_ key) (/.contains? key dict)) - (/.keys dict))) - (_.test "Should be able to get every key." - (list.every? (function (_ key) (case (/.get key dict) - (#.Some _) #1 - _ #0)) - (/.keys dict))) - (_.test "Shouldn't be able to access non-existant keys." - (case (/.get non-key dict) - (#.Some _) #0 - _ #1)) - (_.test "Should be able to put and then get a value." - (case (/.get non-key (/.put non-key test-val dict)) - (#.Some v) (n.= test-val v) - _ #1)) + (do random.monad + [#let [capped-nat (:: random.monad map (n.% 100) random.nat)] + size capped-nat + dict (random.dictionary n.hash size random.nat capped-nat) + non-key (|> random.nat (random.filter (function (_ key) (not (/.contains? key dict))))) + test-val (|> random.nat (random.filter (function (_ val) (not (list.member? n.equivalence (/.values dict) val)))))] + ($_ _.and + (_.cover [/.size] + (n.= size (/.size dict))) + + (_.cover [/.empty?] + (case size + 0 (/.empty? dict) + _ (not (/.empty? dict)))) + + (_.cover [/.new] + (let [sample (/.new n.hash)] + (and (n.= 0 (/.size sample)) + (/.empty? sample)))) + + (_.cover [/.entries /.keys /.values] + (:: (list.equivalence (equivalence.product n.equivalence n.equivalence)) = + (/.entries dict) + (list.zip2 (/.keys dict) + (/.values dict)))) + + (_.cover [/.merge] + (let [merging-with-oneself (let [(^open ".") (/.equivalence n.equivalence)] + (= dict (/.merge dict dict))) + overwritting-keys (let [dict' (|> dict /.entries + (list@map (function (_ [k v]) [k (inc v)])) + (/.from-list n.hash)) + (^open ".") (/.equivalence n.equivalence)] + (= dict' (/.merge dict' dict)))] + (and merging-with-oneself + overwritting-keys))) + + (_.cover [/.merge-with] + (list.every? (function (_ [x x*2]) (n.= (n.* 2 x) x*2)) + (list.zip2 (/.values dict) + (/.values (/.merge-with n.+ dict dict))))) - (_.test "Should be able to try-put and then get a value." - (case (/.try-put non-key test-val dict) - (#try.Success dict) + (_.cover [/.from-list] + (let [(^open ".") (/.equivalence n.equivalence)] + (and (= dict dict) + (|> dict /.entries (/.from-list n.hash) (= dict))))) + ))) + +(def: for-entries + Test + (do random.monad + [#let [capped-nat (:: random.monad map (n.% 100) random.nat)] + size capped-nat + dict (random.dictionary n.hash size random.nat capped-nat) + non-key (|> random.nat (random.filter (function (_ key) (not (/.contains? key dict))))) + test-val (|> random.nat (random.filter (function (_ val) (not (list.member? n.equivalence (/.values dict) val)))))] + ($_ _.and + (_.cover [/.contains?] + (list.every? (function (_ key) (/.contains? key dict)) + (/.keys dict))) + + (_.cover [/.get] + (and (list.every? (function (_ key) (case (/.get key dict) + (#.Some _) true + _ false)) + (/.keys dict)) (case (/.get non-key dict) + (#.Some _) false + _ true))) + + (_.cover [/.put] + (and (n.= (inc (/.size dict)) + (/.size (/.put non-key test-val dict))) + (case (/.get non-key (/.put non-key test-val dict)) (#.Some v) (n.= test-val v) - _ true) + _ true))) + + (_.cover [/.try-put /.key-already-exists] + (let [can-put-new-keys! + (case (/.try-put non-key test-val dict) + (#try.Success dict) + (case (/.get non-key dict) + (#.Some v) (n.= test-val v) + _ true) + + (#try.Failure _) + false) + + cannot-put-old-keys! + (or (n.= 0 size) + (let [first-key (|> dict /.keys list.head maybe.assume)] + (case (/.try-put first-key test-val dict) + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.key-already-exists error))))] + (and can-put-new-keys! + cannot-put-old-keys!))) + + (_.cover [/.remove] + (and (let [base (/.put non-key test-val dict)] + (and (/.contains? non-key base) + (not (/.contains? non-key (/.remove non-key base))))) + (case (list.head (/.keys dict)) + #.None + true + + (#.Some known-key) + (n.= (dec (/.size dict)) + (/.size (/.remove known-key dict)))))) + + (_.cover [/.update] + (let [base (/.put non-key test-val dict) + updt (/.update non-key inc base)] + (case [(/.get non-key base) (/.get non-key updt)] + [(#.Some x) (#.Some y)] + (n.= (inc x) y) + + _ + false))) + + (_.cover [/.upsert] + (let [can-upsert-new-key! + (case (/.get non-key (/.upsert non-key test-val inc dict)) + (#.Some inserted) + (n.= (inc test-val) inserted) - (#try.Failure _) - false)) - (_.test "Shouldn't be able to try-put an existing key." - (or (n.= 0 size) - (let [first-key (|> dict /.keys list.head maybe.assume)] - (case (/.try-put first-key test-val dict) - (#try.Success _) false - (#try.Failure _) true)))) - (_.test "Removing a key should make it's value inaccessible." - (let [base (/.put non-key test-val dict)] - (and (/.contains? non-key base) - (not (/.contains? non-key (/.remove non-key base)))))) - (_.test "Should be possible to update values via their keys." - (let [base (/.put non-key test-val dict) - updt (/.update non-key inc base)] - (case [(/.get non-key base) (/.get non-key updt)] - [(#.Some x) (#.Some y)] - (n.= (inc x) y) + #.None + false) + + can-upsert-old-key! + (case (list.head (/.entries dict)) + #.None + true + + (#.Some [known-key known-value]) + (case (/.get known-key (/.upsert known-key test-val inc dict)) + (#.Some updated) + (n.= (inc known-value) updated) + + #.None + false))] + (and can-upsert-new-key! + can-upsert-old-key!))) + + (_.cover [/.select] + (|> dict + (/.put non-key test-val) + (/.select (list non-key)) + /.size + (n.= 1))) + + (_.cover [/.re-bind] + (or (n.= 0 size) + (let [first-key (|> dict /.keys list.head maybe.assume) + rebound (/.re-bind first-key non-key dict)] + (and (n.= (/.size dict) (/.size rebound)) + (/.contains? non-key rebound) + (not (/.contains? first-key rebound)) + (n.= (maybe.assume (/.get first-key dict)) + (maybe.assume (/.get non-key rebound))))))) + ))) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Dictionary]) + (do random.monad + [#let [capped-nat (:: random.monad map (n.% 100) random.nat)] + size capped-nat + dict (random.dictionary n.hash size random.nat capped-nat) + non-key (|> random.nat (random.filter (function (_ key) (not (/.contains? key dict))))) + test-val (|> random.nat (random.filter (function (_ val) (not (list.member? n.equivalence (/.values dict) val)))))] + ($_ _.and + (_.with-cover [/.equivalence] + ($equivalence.spec (/.equivalence n.equivalence) + (random.dictionary n.hash size random.nat random.nat))) + + (_.with-cover [/.functor] + ($functor.spec ..injection /.equivalence /.functor)) - _ - #0))) - (_.test "Additions and removals to a Dictionary should affect its size." - (let [plus (/.put non-key test-val dict) - base (/.remove non-key plus)] - (and (n.= (inc (/.size dict)) (/.size plus)) - (n.= (dec (/.size plus)) (/.size base))))) - (_.test "A Dictionary should equal itself & going to<->from lists shouldn't change that." - (let [(^open ".") (/.equivalence n.equivalence)] - (and (= dict dict) - (|> dict /.entries (/.from-list n.hash) (= dict))))) - (_.test "Merging a Dictionary to itself changes nothing." - (let [(^open ".") (/.equivalence n.equivalence)] - (= dict (/.merge dict dict)))) - (_.test "If you merge, and the second dict has overlapping keys, it should overwrite yours." - (let [dict' (|> dict /.entries - (list@map (function (_ [k v]) [k (inc v)])) - (/.from-list n.hash)) - (^open ".") (/.equivalence n.equivalence)] - (= dict' (/.merge dict' dict)))) - (_.test "Can merge values in such a way that they become combined." - (list.every? (function (_ [x x*2]) (n.= (n.* 2 x) x*2)) - (list.zip2 (/.values dict) - (/.values (/.merge-with n.+ dict dict))))) - (_.test "Should be able to select subset of keys from dict." - (|> dict - (/.put non-key test-val) - (/.select (list non-key)) - /.size - (n.= 1))) - (_.test "Should be able to re-bind existing values to different keys." - (or (n.= 0 size) - (let [first-key (|> dict /.keys list.head maybe.assume) - rebound (/.re-bind first-key non-key dict)] - (and (n.= (/.size dict) (/.size rebound)) - (/.contains? non-key rebound) - (not (/.contains? first-key rebound)) - (n.= (maybe.assume (/.get first-key dict)) - (maybe.assume (/.get non-key rebound))))))) + ..for-dictionaries + ..for-entries )))) diff --git a/stdlib/source/test/lux/data/format/xml.lux b/stdlib/source/test/lux/data/format/xml.lux index 4c86781c0..6cf842827 100644 --- a/stdlib/source/test/lux/data/format/xml.lux +++ b/stdlib/source/test/lux/data/format/xml.lux @@ -78,10 +78,10 @@ num-children (|> r.nat (:: @ map (n.% 5))) children (r.list num-children (..text 1 10)) tag xml-identifier^ - attr xml-identifier^ + attribute xml-identifier^ value (..text 1 10) #let [node (#/.Node tag - (dictionary.put attr value /.attrs) + (dictionary.put attribute value /.attrs) (list@map (|>> #/.Text) children))]] ($_ _.and (_.test "Can parse text." @@ -94,7 +94,7 @@ (E.default #0 (do E.monad [output (</>.run (p.before </>.ignore - (</>.attr attr)) + (</>.attribute attribute)) node)] (wrap (text@= value output))))) (_.test "Can parse nodes." diff --git a/stdlib/source/test/lux/macro/poly/json.lux b/stdlib/source/test/lux/macro/poly/json.lux index 144994f50..8be02dc27 100644 --- a/stdlib/source/test/lux/macro/poly/json.lux +++ b/stdlib/source/test/lux/macro/poly/json.lux @@ -79,10 +79,9 @@ (Random Recursive) (random.rec (function (_ gen-recursive) - (random.or random.frac - (random.and random.frac gen-recursive))))) - -(derived: recursive-equivalence (poly/equivalence.equivalence Recursive)) + (random.or random.safe-frac + (random.and random.safe-frac + gen-recursive))))) (def: qty (All [unit] (Random (unit.Qty unit))) @@ -94,13 +93,13 @@ [size (:: @ map (n.% 2) random.nat)] ($_ random.and random.bit - random.frac + random.safe-frac (random.unicode size) - (random.maybe random.frac) - (random.list size random.frac) - (random.dictionary text.hash size (random.unicode size) random.frac) - ($_ random.or random.bit (random.unicode size) random.frac) - ($_ random.and random.bit (random.unicode size) random.frac) + (random.maybe random.safe-frac) + (random.list size random.safe-frac) + (random.dictionary text.hash size (random.unicode size) random.safe-frac) + ($_ random.or random.bit (random.unicode size) random.safe-frac) + ($_ random.and random.bit (random.unicode size) random.safe-frac) ..gen-recursive ## _instant.instant ## _duration.duration @@ -108,8 +107,11 @@ ..qty ))) -(derived: equivalence (poly/equivalence.equivalence Record)) -(derived: codec (/.codec Record)) +(derived: equivalence + (poly/equivalence.equivalence Record)) + +(derived: codec + (/.codec Record)) (def: #export test Test diff --git a/stdlib/source/test/lux/world/file.lux b/stdlib/source/test/lux/world/file.lux index 0fd4d76f3..9dc1fb2e2 100644 --- a/stdlib/source/test/lux/world/file.lux +++ b/stdlib/source/test/lux/world/file.lux @@ -70,8 +70,8 @@ (<| (_.context (%.name (name-of /._))) (do {@ r.monad} [file-size (|> r.nat (:: @ map (|>> (n.% 100) (n.max 10)))) - dataL (_binary.binary file-size) - dataR (_binary.binary file-size) + dataL (_binary.random file-size) + dataR (_binary.random file-size) new-modified (|> r.int (:: @ map (|>> i.abs (i.% +10,000,000,000,000) truncate-millis |