diff options
Diffstat (limited to '')
28 files changed, 831 insertions, 170 deletions
diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 8cc4dfe94..f170baffe 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -83,7 +83,7 @@ (..throw exception message))) (syntax: #export (exception: {export scr.export} - {t-vars (p.default (list) scr.type-variables)} + {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))))} {body (p.maybe s.any)}) diff --git a/stdlib/source/lux/control/parser/xml.lux b/stdlib/source/lux/control/parser/xml.lux index f734a2684..bea101164 100644 --- a/stdlib/source/lux/control/parser/xml.lux +++ b/stdlib/source/lux/control/parser/xml.lux @@ -13,7 +13,7 @@ ["." list ("#@." functor)] ["." dictionary]] [format - ["/" xml (#+ XML)]]]] + ["/" xml (#+ Attribute Tag XML)]]]] ["." //]) (type: #export (Parser a) @@ -26,13 +26,13 @@ (-> Name Text) (format namespace ":" name)) -(template [<exception> <header>] - [(exception: #export (<exception> {label Name}) +(template [<exception> <type> <header>] + [(exception: #export (<exception> {label <type>}) (exception.report [<header> (%.text (..label label))]))] - [wrong-tag "Tag"] - [unknown-attribute "Attribute"] + [wrong-tag Tag "Tag"] + [unknown-attribute Attribute "Attribute"] ) (def: blank-line @@ -59,7 +59,7 @@ (exception.throw ..unexpected-input []))))) (def: #export (node tag) - (-> Name (Parser Any)) + (-> Tag (Parser Any)) (function (_ docs) (case docs #.Nil @@ -75,8 +75,23 @@ (#try.Success [docs []]) (exception.throw ..wrong-tag tag)))))) +(def: #export tag + (Parser Tag) + (function (_ docs) + (case docs + #.Nil + (exception.throw ..empty-input []) + + (#.Cons head _) + (case head + (#/.Text _) + (exception.throw ..unexpected-input []) + + (#/.Node tag _attrs _children) + (#try.Success [docs tag]))))) + (def: #export (attr name) - (-> Name (Parser Text)) + (-> Attribute (Parser Text)) (function (_ docs) (case docs #.Nil @@ -95,9 +110,9 @@ (#.Some value) (#try.Success [docs value])))))) -(def: (run' reader docs) +(def: (run' parser docs) (All [a] (-> (Parser a) (List XML) (Try a))) - (case (//.run reader docs) + (case (//.run parser docs) (#try.Success [remaining output]) (if (list.empty? remaining) (#try.Success output) @@ -106,7 +121,7 @@ (#try.Failure error) (#try.Failure error))) -(def: #export (children reader) +(def: #export (children parser) (All [a] (-> (Parser a) (Parser a))) (function (_ docs) (case docs @@ -118,9 +133,9 @@ (#/.Text _) (exception.throw ..unexpected-input []) - (#/.Node _tag _attrs _children) + (#/.Node _tag _attrs children) (do try.monad - [output (run' reader _children)] + [output (run' parser children)] (wrap [tail output])))))) (def: #export ignore @@ -133,6 +148,6 @@ (#.Cons head tail) (#try.Success [tail []])))) -(def: #export (run reader document) +(def: #export (run parser document) (All [a] (-> (Parser a) XML (Try a))) - (run' reader (list document))) + (..run' parser (list document))) diff --git a/stdlib/source/lux/data/binary.lux b/stdlib/source/lux/data/binary.lux index 8a5157b4a..ed0d992e9 100644 --- a/stdlib/source/lux/data/binary.lux +++ b/stdlib/source/lux/data/binary.lux @@ -4,7 +4,8 @@ ["@" target] [abstract [monad (#+ do)] - [equivalence (#+ Equivalence)]] + [equivalence (#+ Equivalence)] + [monoid (#+ Monoid)]] [control ["." try (#+ Try)] ["." exception (#+ exception:)]] @@ -302,3 +303,18 @@ (def: #export (slice' from binary) (-> Nat Binary (Try Binary)) (slice from (dec (..!size binary)) binary)) + +(structure: #export monoid + (Monoid Binary) + + (def: identity + (..create 0)) + + (def: (compose left right) + (let [sizeL (!size left) + sizeR (!size right) + output (..create (n.+ sizeL sizeR))] + (exec + (..copy sizeL 0 left 0 output) + (..copy sizeR 0 right sizeL output) + output)))) diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index 83a3209d4..390f070f0 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -22,8 +22,11 @@ (type: #export Tag Name) +(type: #export Attribute + Name) + (type: #export Attrs - (Dictionary Name Text)) + (Dictionary Attribute Text)) (def: #export attrs Attrs @@ -235,8 +238,8 @@ (structure: #export codec (Codec Text XML) - (def: encode write) - (def: decode read)) + (def: encode ..write) + (def: decode ..read)) (structure: #export equivalence (Equivalence XML) diff --git a/stdlib/source/lux/data/number/i64.lux b/stdlib/source/lux/data/number/i64.lux index a9b1afb3b..26bc0cdc9 100644 --- a/stdlib/source/lux/data/number/i64.lux +++ b/stdlib/source/lux/data/number/i64.lux @@ -8,9 +8,11 @@ [number ["n" nat]]]]) -(def: #export bits-per-byte 8) +(def: #export bits-per-byte + 8) -(def: #export bytes-per-i64 8) +(def: #export bytes-per-i64 + 8) (def: #export width Nat diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 069dd8590..ed4b540f7 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -16,7 +16,8 @@ [collection ["." list ("#@." fold)]]]]) -(type: #export Char Nat) +(type: #export Char + Nat) ## TODO: Instead of ints, chars should be produced fron nats. ## (The JVM specifies chars as 16-bit unsigned integers) @@ -168,23 +169,31 @@ #.None template)) -(structure: #export equivalence (Equivalence Text) +(structure: #export equivalence + (Equivalence Text) + (def: (= reference sample) ("lux text =" reference sample))) -(structure: #export order (Order Text) +(structure: #export order + (Order Text) + (def: &equivalence ..equivalence) (def: (< reference sample) ("lux text <" reference sample))) -(structure: #export monoid (Monoid Text) +(structure: #export monoid + (Monoid Text) + (def: identity "") (def: (compose left right) ("lux text concat" left right))) -(structure: #export hash (Hash Text) +(structure: #export hash + (Hash Text) + (def: &equivalence ..equivalence) (def: (hash input) @@ -252,7 +261,8 @@ (-> Text Text) (..enclose' ..double-quote)) -(def: #export space Text " ") +(def: #export space + " ") (def: #export (space? char) {#.doc "Checks whether the character is white-space."} diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux index 0729c05fe..15c9a1fc4 100644 --- a/stdlib/source/lux/macro/syntax/common.lux +++ b/stdlib/source/lux/macro/syntax/common.lux @@ -18,9 +18,11 @@ #definition-type (Maybe Code) #definition-value Code #definition-anns Annotations - #definition-args (List Text) - }) + #definition-args (List Text)}) (type: #export Typed-Input {#input-binding Code #input-type Code}) + +(type: #export Type-Var + Text) diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux index 5e2d3b0bc..989d2a0e2 100644 --- a/stdlib/source/lux/macro/syntax/common/reader.lux +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -128,7 +128,7 @@ {#.doc "A reader for definitions that ensures the input syntax is typed."} (-> Lux (Parser //.Definition)) (do p.monad - [_definition (definition compiler) + [_definition (..definition compiler) _ (case (get@ #//.definition-type _definition) (#.Some _) (wrap []) @@ -145,4 +145,4 @@ (def: #export type-variables {#.doc "Reader for the common type var/param used by many macros."} (Parser (List Text)) - (s.tuple (p.some s.local-identifier))) + (p.some s.local-identifier)) diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux index 541f8849b..a067f0c10 100644 --- a/stdlib/source/lux/macro/syntax/common/writer.lux +++ b/stdlib/source/lux/macro/syntax/common/writer.lux @@ -28,6 +28,11 @@ (|>> (list@map (product.both code.tag function.identity)) code.record)) +(def: #export (typed-input value) + (-> //.Typed-Input Code) + (code.record (list [(get@ #//.input-binding value) + (get@ #//.input-type value)]))) + (def: #export type-variables - (-> (List Text) (List Code)) + (-> (List //.Type-Var) (List Code)) (list@map code.local-identifier)) diff --git a/stdlib/source/lux/world/net/http.lux b/stdlib/source/lux/world/net/http.lux index 67acbde6b..4a98fa492 100644 --- a/stdlib/source/lux/world/net/http.lux +++ b/stdlib/source/lux/world/net/http.lux @@ -10,9 +10,11 @@ [context (#+ Context)]]] [world [binary (#+ Binary)]]] - [// (#+ URL)]) + [// (#+ URL) + [uri (#+ URI)]]) -(type: #export Version Text) +(type: #export Version + Text) (type: #export Method #Post @@ -25,9 +27,11 @@ #Options #Trace) -(type: #export Port Nat) +(type: #export Port + Nat) -(type: #export Status Nat) +(type: #export Status + Nat) (type: #export Header (-> Context Context)) @@ -38,9 +42,6 @@ (type: #export Body (Channel Data)) -(type: #export URI - Text) - (type: #export Scheme #HTTP #HTTPS) diff --git a/stdlib/source/lux/world/net/uri.lux b/stdlib/source/lux/world/net/uri.lux new file mode 100644 index 000000000..e7d70d108 --- /dev/null +++ b/stdlib/source/lux/world/net/uri.lux @@ -0,0 +1,8 @@ +(.module: + [lux #*]) + +(type: #export URI + Text) + +(def: #export separator + "/") diff --git a/stdlib/source/poly/lux/data/format/json.lux b/stdlib/source/poly/lux/data/format/json.lux index b324790fb..8992b7ab6 100644 --- a/stdlib/source/poly/lux/data/format/json.lux +++ b/stdlib/source/poly/lux/data/format/json.lux @@ -284,12 +284,12 @@ (~+ (list@map (function (_ [tag memberC]) (if (n.= last tag) (` (|> (~ memberC) - ((~! p.after) ((~! </>.number!) (~ (code.frac (..tag (dec tag)))))) ((~! p.after) ((~! </>.boolean!) (~ (code.bit #1)))) + ((~! p.after) ((~! </>.number!) (~ (code.frac (..tag (dec tag)))))) ((~! </>.array)))) (` (|> (~ memberC) - ((~! p.after) ((~! </>.number!) (~ (code.frac (..tag tag))))) ((~! p.after) ((~! </>.boolean!) (~ (code.bit #0)))) + ((~! p.after) ((~! </>.number!) (~ (code.frac (..tag tag))))) ((~! </>.array)))))) (list.enumerate members)))))))) (do @ diff --git a/stdlib/source/program/aedifex.lux b/stdlib/source/program/aedifex.lux index 6909704dd..0ca614be1 100644 --- a/stdlib/source/program/aedifex.lux +++ b/stdlib/source/program/aedifex.lux @@ -12,7 +12,7 @@ [security ["!" capability]] [concurrency - ["." promise]]] + ["." promise (#+ Promise)]]] [data [binary (#+ Binary)] ["." text @@ -32,7 +32,8 @@ ["#." parser] ["#." pom] ["#." cli] - ["#." local]]) + ["#." local] + ["#." dependency]]) (def: (read-file! path) (-> Path (IO (Try Binary))) @@ -40,16 +41,6 @@ [project-file (!.use (:: file.system file) [path])] (!.use (:: project-file content) []))) -(def: (write-pom! path project) - (-> Path /.Project (IO (Try Any))) - (do (try.with io.monad) - [file (!.use (:: file.system file) [path])] - (|> project - /pom.project - (:: xml.codec encode) - encoding.to-utf8 - (!.use (:: file over-write))))) - (def: (read-code source-code) (-> Text (Try Code)) (let [parse (syntax.parse "" @@ -64,6 +55,61 @@ (#.Right [end lux-code]) (#try.Success lux-code)))) +(def: (write-pom!' path project) + (-> Path /.Project (IO (Try Any))) + (do (try.with io.monad) + [file (!.use (:: file.system file) [path])] + (|> project + /pom.project + (:: xml.codec encode) + encoding.to-utf8 + (!.use (:: file over-write))))) + +(def: (write-pom! project) + (-> /.Project (IO Any)) + (do io.monad + [outcome (write-pom!' /pom.file project)] + (case outcome + (#try.Success value) + (wrap (log! "Successfully wrote POM file!")) + + (#try.Failure error) + (wrap (log! (format "Could not write POM file:" text.new-line + error)))))) + +(def: (install! project) + (-> /.Project (Promise Any)) + (do promise.monad + [outcome (/local.install (file.async file.system) project)] + (wrap (case outcome + (#try.Success _) + (log! "Successfully installed locally!") + + (#try.Failure error) + (log! (format "Could not install locally:" text.new-line + error)))))) + +(def: (fetch-dependencies! project) + (-> /.Project (Promise Any)) + (do promise.monad + [outcome (do (try.with promise.monad) + [cache (/local.all-cached (file.async file.system) + (get@ #/.dependencies project) + /dependency.empty) + resolution (promise.future + (/dependency.resolve-all (get@ #/.repositories project) + (get@ #/.dependencies project) + cache))] + (/local.cache-all (file.async file.system) + resolution))] + (wrap (case outcome + (#try.Success _) + (log! "Successfully resolved dependencies!") + + (#try.Failure error) + (log! (format "Could not resolve dependencies:" text.new-line + error)))))) + (def: project (-> Binary (Try /.Project)) (|>> (do> try.monad @@ -80,26 +126,14 @@ (#try.Success project) (case command #/cli.POM - (do @ - [outcome (..write-pom! /pom.file project)] - (case outcome - (#try.Success value) - (wrap (log! "Successfully wrote POM file!")) - - (#try.Failure error) - (wrap (log! (format "Could not write POM file:" text.new-line - error))))) + (..write-pom! project) #/cli.Install - (exec (do promise.monad - [outcome (/local.install (file.async file.system) project)] - (wrap (case outcome - (#try.Success _) - (log! "Successfully installed locally!") - - (#try.Failure error) - (log! (format "Could not install locally:" text.new-line - error))))) + (exec (..install! project) + (wrap [])) + + #/cli.Dependencies + (exec (..fetch-dependencies! project) (wrap []))) (#try.Failure error) diff --git a/stdlib/source/program/aedifex/artifact.lux b/stdlib/source/program/aedifex/artifact.lux new file mode 100644 index 000000000..a6865f688 --- /dev/null +++ b/stdlib/source/program/aedifex/artifact.lux @@ -0,0 +1,68 @@ +(.module: + [lux (#- Name) + [abstract + ["." hash (#+ Hash)]] + [data + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#@." monoid)]]] + [world + [net + ["." uri]]]]) + +(type: #export Group + Text) + +(type: #export Name + Text) + +(type: #export Version + Text) + +(type: #export Artifact + {#group Group + #name Name + #version Version}) + +(def: #export hash + (Hash Artifact) + ($_ hash.product + text.hash + text.hash + text.hash + )) + +(def: group-separator + ".") + +(def: version-separator + "-") + +(def: #export (identity artifact) + (-> Artifact Text) + (format (get@ #name artifact) + ..version-separator + (get@ #version artifact))) + +(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)))) + +(def: #export (local artifact) + (-> Artifact (List Text)) + (list@compose (|> artifact + (get@ #group) + (text.split-all-with ..group-separator)) + (list (get@ #name artifact) + (get@ #version artifact)))) diff --git a/stdlib/source/program/aedifex/cli.lux b/stdlib/source/program/aedifex/cli.lux index 5f75cac9b..4ff56ac53 100644 --- a/stdlib/source/program/aedifex/cli.lux +++ b/stdlib/source/program/aedifex/cli.lux @@ -6,11 +6,13 @@ (type: #export Command #POM - #Install) + #Install + #Dependencies) (def: #export command (Parser Command) ($_ <>.or (cli.this "pom") (cli.this "install") + (cli.this "deps") )) diff --git a/stdlib/source/program/aedifex/dependency.lux b/stdlib/source/program/aedifex/dependency.lux index 473d5498e..7c40bf2ae 100644 --- a/stdlib/source/program/aedifex/dependency.lux +++ b/stdlib/source/program/aedifex/dependency.lux @@ -1,12 +1,55 @@ (.module: - [lux (#- Type)] + [lux (#- Name Type) + ["." host (#+ import:)] + [abstract + [monad (#+ do)] + ["." 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)]]] + [world + [net (#+ URL) + ["." uri]]]] ["." // #_ + ["#." extension] + ["#." artifact (#+ Artifact)] ["#." hash]]) +(type: #export Repository + URL) + ## https://maven.apache.org/ref/3.6.3/maven-core/artifact-handlers.html (type: #export Type Text) +(type: #export Dependency + {#artifact Artifact + #type ..Type}) + +(def: #export hash + (Hash Dependency) + ($_ hash.product + //artifact.hash + text.hash + )) + (template [<type> <name>] [(def: #export <name> Type @@ -15,3 +58,234 @@ ["tar" lux-library] ["jar" jvm-library] ) + +(import: #long java/lang/String) + +(import: #long java/lang/AutoCloseable + (close [] #io #try void)) + +(import: #long java/io/InputStream) + +(import: #long java/net/URL + (new [java/lang/String]) + (openStream [] #io #try java/io/InputStream)) + +(import: #long 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))))))))) + +(def: hex-per-byte + 2) + +(def: hex-per-nat + (n.* hex-per-byte i64.bytes-per-i64)) + +(type: Hash-Reader + (-> Binary (Try //hash.Hash))) + +(def: (sha1 input) + Hash-Reader + (do try.monad + [input (encoding.from-utf8 input) + [left input] (try.from-maybe (text.split ..hex-per-nat input)) + [middle right] (try.from-maybe (text.split ..hex-per-nat input)) + #let [output (:: binary.monoid identity)] + left (:: n.hex decode left) + output (binary.write/64 0 left output) + middle (:: n.hex decode middle) + output (binary.write/64 i64.bytes-per-i64 middle output) + right (:: n.hex decode right)] + (binary.write/64 (n.* 2 i64.bytes-per-i64) right output))) + +(def: (md5 input) + Hash-Reader + (do try.monad + [input (encoding.from-utf8 input) + [left right] (try.from-maybe (text.split ..hex-per-nat input)) + #let [output (:: binary.monoid identity)] + left (:: n.hex decode left) + output (binary.write/64 0 left output) + right (:: n.hex decode right)] + (binary.write/64 i64.bytes-per-i64 right output))) + +(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 reader exception) + (-> Dependency Binary URL (-> Binary //hash.Hash) Hash-Reader (Exception [Dependency Text]) + (IO (Try Text))) + (do (try.with io.monad) + [#let [reference (hash library)] + actual (..download url)] + (:: io.monad wrap + (do try.monad + [output (encoding.from-utf8 actual) + actual (reader actual) + _ (exception.assert exception [dependency output] + (:: binary.equivalence = reference 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 ..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 "." type)) + sha1 (..verified-hash dependency library (format prefix //extension.sha1) //hash.sha1 ..sha1 ..sha1-does-not-match) + md5 (..verified-hash dependency library (format prefix //extension.md5) //hash.md5 ..md5 ..md5-does-not-match) + pom (..download (format prefix //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/extension.lux b/stdlib/source/program/aedifex/extension.lux new file mode 100644 index 000000000..6caa343aa --- /dev/null +++ b/stdlib/source/program/aedifex/extension.lux @@ -0,0 +1,11 @@ +(.module: + [lux #*]) + +(def: #export sha1 + ".sha1") + +(def: #export md5 + ".md5") + +(def: #export pom + ".pom") diff --git a/stdlib/source/program/aedifex/hash.lux b/stdlib/source/program/aedifex/hash.lux index bd4396006..63511a74d 100644 --- a/stdlib/source/program/aedifex/hash.lux +++ b/stdlib/source/program/aedifex/hash.lux @@ -2,7 +2,11 @@ [lux #* ["." host (#+ import:)] [data - ["." binary (#+ Binary)]]]) + ["." binary (#+ Binary)] + ["." text + ["%" format (#+ format)]] + [number + ["." nat]]]]) ## TODO: Replace with pure-Lux implementations of these algorithms ## https://en.wikipedia.org/wiki/SHA-1#SHA-1_pseudocode @@ -25,3 +29,13 @@ [sha1 "SHA-1"] [md5 "MD5"] ) + +(def: #export representation + (-> Hash Text) + (binary.fold (function (_ byte representation) + (let [hex (:: nat.hex encode byte) + hex (case (text.size hex) + 1 (format "0" hex) + _ hex)] + (format representation hex))) + "")) diff --git a/stdlib/source/program/aedifex/local.lux b/stdlib/source/program/aedifex/local.lux index 15d9a9323..8761b573a 100644 --- a/stdlib/source/program/aedifex/local.lux +++ b/stdlib/source/program/aedifex/local.lux @@ -15,7 +15,8 @@ ["%" format (#+ format)] ["." encoding]] [collection - ["." list ("#@." monoid)]] + ["." list ("#@." monoid)] + ["." dictionary]] [format ["." binary] ["." tar] @@ -26,12 +27,12 @@ [compositor ["." export]]] ["." // #_ - ["#." project (#+ Project)] + ["/" project (#+ Project)] + ["#." extension] ["#." pom] - ["#." dependency]]) - -(def: group-separator - ".") + ["#." artifact (#+ Artifact)] + ["#." dependency (#+ Package Resolution Dependency)] + ["#." hash]]) (def: (local system) (All [a] (-> (file.System a) Path)) @@ -41,13 +42,12 @@ (All [a] (-> (file.System a) Path)) (format (..local system) (:: system separator) "repository")) -(def: (guarantee-repository! system project) - (-> (file.System Promise) Project (Promise (Try Path))) +(def: (guarantee-repository! system artifact) + (-> (file.System Promise) Artifact (Promise (Try Path))) (do {@ (try.with promise.monad)} [_ (: (Promise (Try (Directory Promise))) (file.get-directory promise.monad system (..local system))) - #let [root (..repository system) - identity (get@ #//project.identity project)] + #let [root (..repository system)] _ (: (Promise (Try (Directory Promise))) (file.get-directory promise.monad system root))] (monad.fold @ @@ -58,11 +58,7 @@ (file.get-directory promise.monad system path))] (wrap path))) root - (list@compose (|> identity - (get@ #//project.group) - (text.split-all-with ..group-separator)) - (list (get@ #//project.name identity) - (get@ #//project.version identity)))))) + (//artifact.local artifact)))) (def: (save! system content file) (-> (file.System Promise) Binary Path (Promise (Try Any))) @@ -74,13 +70,93 @@ (def: #export (install system project) (-> (file.System Promise) Project (Promise (Try Any))) (do (try.with promise.monad) - [repository (..guarantee-repository! system project) - #let [identity (get@ #//project.identity project) - artifact-name (format repository - (:: system separator) (get@ #//project.name identity) - "-" (get@ #//project.version identity))] - package (export.library system (get@ #//project.sources project)) + [repository (..guarantee-repository! system (get@ #/.identity project)) + #let [identity (get@ #/.identity project) + artifact-name (format repository (:: system separator) (//artifact.identity identity))] + package (export.library system (get@ #/.sources project)) _ (..save! system (binary.run tar.writer package) (format artifact-name "." //dependency.lux-library))] (..save! system (|> project //pom.project (:: xml.codec encode) encoding.to-utf8) - (format artifact-name //pom.extension)))) + (format artifact-name //extension.pom)))) + +(def: #export (cache system [artifact type] package) + (-> (file.System Promise) Dependency Package (Promise (Try Any))) + (do (try.with promise.monad) + [directory (..guarantee-repository! system artifact) + #let [prefix (format directory (:: system separator) (//artifact.identity artifact))] + directory (: (Promise (Try (Directory Promise))) + (file.get-directory promise.monad system directory)) + _ (..save! system + (get@ #//dependency.library package) + (format prefix "." type)) + _ (..save! system + (encoding.to-utf8 (get@ #//dependency.sha1 package)) + (format prefix //extension.sha1)) + _ (..save! system + (encoding.to-utf8 (get@ #//dependency.md5 package)) + (format prefix //extension.md5)) + _ (..save! system + (|> package (get@ #//dependency.pom) (:: xml.codec encode) encoding.to-utf8) + (format prefix //extension.pom))] + (wrap []))) + +(def: #export (cache-all system resolution) + (-> (file.System Promise) Resolution (Promise (Try Any))) + (do {@ (try.with promise.monad)} + [_ (monad.map @ (function (_ [dependency package]) + (..cache system dependency package)) + (dictionary.entries resolution))] + (wrap []))) + +(def: (read! system path) + (-> (file.System Promise) Path (Promise (Try Binary))) + (do (try.with promise.monad) + [file (: (Promise (Try (File Promise))) + (!.use (:: system file) path))] + (!.use (:: file content) []))) + +(def: #export (cached system [artifact type]) + (-> (file.System Promise) Dependency (Promise (Try Package))) + (do (try.with promise.monad) + [directory (..guarantee-repository! system artifact) + #let [prefix (format directory (:: system separator) (//artifact.identity artifact))] + pom (..read! system (format prefix //extension.pom)) + [pom dependencies] (:: promise.monad wrap + (do try.monad + [pom (encoding.from-utf8 pom) + pom (:: xml.codec decode pom) + dependencies (//dependency.from-pom pom)] + (wrap [pom dependencies]))) + library (..read! system (format prefix "." type)) + sha1 (..read! system (format prefix //extension.sha1)) + md5 (..read! system (format prefix //extension.md5))] + (wrap {#//dependency.library library + #//dependency.pom pom + #//dependency.dependencies dependencies + #//dependency.sha1 (//hash.representation sha1) + #//dependency.md5 (//hash.representation md5)}))) + +(def: #export (all-cached system dependencies resolution) + (-> (file.System Promise) (List Dependency) Resolution (Promise (Try Resolution))) + (case dependencies + #.Nil + (:: (try.with promise.monad) wrap resolution) + + (#.Cons head tail) + (do promise.monad + [package (case (dictionary.get head resolution) + (#.Some package) + (wrap (#try.Success package)) + + #.None + (..cached system head))] + (with-expansions [<next> (as-is (all-cached system tail resolution))] + (case package + (#try.Success package) + (let [resolution (dictionary.put head package resolution)] + (do (try.with promise.monad) + [resolution (all-cached system (get@ #//dependency.dependencies package) resolution)] + <next>)) + + (#try.Failure error) + <next>))))) diff --git a/stdlib/source/program/aedifex/parser.lux b/stdlib/source/program/aedifex/parser.lux index 1a4b2f638..78f6dbb60 100644 --- a/stdlib/source/program/aedifex/parser.lux +++ b/stdlib/source/program/aedifex/parser.lux @@ -11,26 +11,27 @@ [net (#+ URL)]]] [// ["/" project] + ["//." artifact (#+ Artifact)] ["//." dependency]]) (def: group - (Parser /.Group) + (Parser //artifact.Group) <c>.text) (def: name - (Parser /.Name) + (Parser //artifact.Name) <c>.text) (def: version - (Parser /.Version) + (Parser //artifact.Version) <c>.text) (def: artifact' - (Parser /.Artifact) + (Parser //artifact.Artifact) ($_ <>.and ..group ..name ..version)) (def: artifact - (Parser /.Artifact) + (Parser //artifact.Artifact) (<c>.tuple ..artifact')) (def: url @@ -106,7 +107,7 @@ )) (def: repository - (Parser /.Repository) + (Parser //dependency.Repository) ..url) (def: type @@ -114,7 +115,7 @@ <c>.text) (def: dependency - (Parser /.Dependency) + (Parser //dependency.Dependency) (<c>.tuple ($_ <>.and ..artifact' diff --git a/stdlib/source/program/aedifex/pom.lux b/stdlib/source/program/aedifex/pom.lux index 102728e1e..794ed7e12 100644 --- a/stdlib/source/program/aedifex/pom.lux +++ b/stdlib/source/program/aedifex/pom.lux @@ -8,17 +8,16 @@ ["_" xml (#+ XML)]] [collection ["." list ("#@." monoid functor)]]]] - [// - ["/" project]]) + ["." // #_ + ["/" project] + ["#." artifact (#+ Artifact)] + ["#." dependency (#+ Repository Dependency)]]) ## https://maven.apache.org/pom.html (def: #export file "pom.xml") -(def: #export extension - ".pom") - (def: version XML (#_.Node ["" "modelVersion"] _.attrs @@ -31,10 +30,10 @@ (list (#_.Text value)))) (def: (artifact value) - (-> /.Artifact (List XML)) - (list (..property "groupId" (get@ #/.group value)) - (..property "artifactId" (get@ #/.name value)) - (..property "version" (get@ #/.version value)))) + (-> Artifact (List XML)) + (list (..property "groupId" (get@ #//artifact.group value)) + (..property "artifactId" (get@ #//artifact.name value)) + (..property "version" (get@ #//artifact.version value)))) (def: distribution (-> /.Distribution XML) @@ -50,17 +49,17 @@ (#_.Node ["" "license"] _.attrs))) (def: repository - (-> /.Repository XML) + (-> Repository XML) (|>> (..property "url") list (#_.Node ["" "repository"] _.attrs))) -(def: (dependency [artifact type]) - (-> /.Dependency XML) +(def: (dependency value) + (-> Dependency XML) (#_.Node ["" "dependency"] _.attrs - (list@compose (..artifact artifact) - (list (..property "type" type))))) + (list@compose (..artifact (get@ #//dependency.artifact value)) + (list (..property "type" (get@ #//dependency.type value)))))) (def: scm (-> /.SCM XML) diff --git a/stdlib/source/program/aedifex/project.lux b/stdlib/source/program/aedifex/project.lux index 9f98ebc51..385ef8919 100644 --- a/stdlib/source/program/aedifex/project.lux +++ b/stdlib/source/program/aedifex/project.lux @@ -1,34 +1,23 @@ (.module: - [lux (#- Name Info Source) + [lux (#- Info Source) + [data + ["." text]] [world [net (#+ URL)] [file (#+ Path)]]] [// + [artifact (#+ Artifact)] ["." dependency]]) (def: #export file "project.lux") -(type: #export Group - Text) - -(type: #export Name - Text) - -(type: #export Version - Text) - -(type: #export Artifact - {#group Group - #name Name - #version Version}) - (type: #export Distribution #Repo #Manual) (type: #export License - [Name + [Text URL Distribution]) @@ -36,14 +25,14 @@ URL) (type: #export Organization - [Name + [Text URL]) (type: #export Email Text) (type: #export Developer - [Name + [Text Email (Maybe Organization)]) @@ -59,18 +48,12 @@ #developers (List Developer) #contributors (List Contributor)}) -(type: #export Repository - URL) - -(type: #export Dependency - [Artifact dependency.Type]) - (type: #export Source Path) (type: #export Project {#identity Artifact #info Info - #repositories (List Repository) - #dependencies (List Dependency) + #repositories (List dependency.Repository) + #dependencies (List dependency.Dependency) #sources (List Source)}) diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux index 4d9632b8c..6c52dc5ad 100644 --- a/stdlib/source/test/lux/control/concurrency/frp.lux +++ b/stdlib/source/test/lux/control/concurrency/frp.lux @@ -169,7 +169,7 @@ (list@= (list distint/0 distint/1 distint/2) actual)))) (let [polling-delay 10 - wiggle-room (n.* 3 polling-delay) + wiggle-room (n.* 5 polling-delay) amount-of-polls 5 total-delay (|> polling-delay (n.* amount-of-polls) diff --git a/stdlib/source/test/lux/control/function/memo.lux b/stdlib/source/test/lux/control/function/memo.lux index 564e37a87..a57adaa53 100644 --- a/stdlib/source/test/lux/control/function/memo.lux +++ b/stdlib/source/test/lux/control/function/memo.lux @@ -50,7 +50,7 @@ Test (<| (_.covering /._) (do {@ random.monad} - [input (|> random.nat (:: @ map (|>> (n.% 5) (n.+ 22))))]) + [input (|> random.nat (:: @ map (|>> (n.% 5) (n.+ 23))))]) (_.with-cover [/.Memo]) ($_ _.and (_.cover [/.closed /.none] diff --git a/stdlib/source/test/lux/macro.lux b/stdlib/source/test/lux/macro.lux index 4875820b6..1851fb4a4 100644 --- a/stdlib/source/test/lux/macro.lux +++ b/stdlib/source/test/lux/macro.lux @@ -6,7 +6,8 @@ ["." /]} ["." / #_ ["#." code] - ["#." syntax] + ["#." syntax + ["#/." common]] ["#." poly #_ ["#/." equivalence] ["#/." functor] @@ -18,6 +19,7 @@ ($_ _.and /code.test /syntax.test + /syntax/common.test /poly/equivalence.test /poly/functor.test /poly/json.test diff --git a/stdlib/source/test/lux/macro/code.lux b/stdlib/source/test/lux/macro/code.lux index 0fc1c24be..00a805f26 100644 --- a/stdlib/source/test/lux/macro/code.lux +++ b/stdlib/source/test/lux/macro/code.lux @@ -45,7 +45,7 @@ [size (|> random.nat (:: @ map (n.% 3)))] (random.list size (random.and random random)))) -(def: random +(def: #export random (Random Code) (random.rec (function (_ random) diff --git a/stdlib/source/test/lux/macro/poly/json.lux b/stdlib/source/test/lux/macro/poly/json.lux index 5e0bcfbd4..55b2d2dd2 100644 --- a/stdlib/source/test/lux/macro/poly/json.lux +++ b/stdlib/source/test/lux/macro/poly/json.lux @@ -1,6 +1,5 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract codec @@ -20,7 +19,8 @@ [data ["." bit] ["." maybe] - ["." text] + ["." text + ["%" format (#+ format)]] [number ["n" nat] ["." frac]] @@ -37,7 +37,7 @@ [type ["." unit]] [math - ["r" random (#+ Random)]] + ["." random (#+ Random)]] [time ["ti" instant] ["tda" date] @@ -67,39 +67,39 @@ #list (List Frac) #dictionary (d.Dictionary Text Frac) #variant Variant - #tuple [Bit Frac Text] + #tuple [Bit Text Frac] #recursive Recursive ## #instant ti.Instant ## #duration tdu.Duration #date tda.Date - #grams (unit.Qty unit.Gram) - }) + #grams (unit.Qty unit.Gram)}) (def: gen-recursive (Random Recursive) - (r.rec (function (_ gen-recursive) - (r.or r.frac - (r.and r.frac gen-recursive))))) + (random.rec + (function (_ gen-recursive) + (random.or random.frac + (random.and random.frac gen-recursive))))) (derived: recursive-equivalence (poly/equivalence.equivalence Recursive)) (def: qty (All [unit] (Random (unit.Qty unit))) - (|> r.int (:: r.monad map unit.in))) + (|> random.int (:: random.monad map unit.in))) (def: gen-record (Random Record) - (do {@ r.monad} - [size (:: @ map (n.% 2) r.nat)] - ($_ r.and - r.bit - r.frac - (r.unicode size) - (r.maybe r.frac) - (r.list size r.frac) - (r.dictionary text.hash size (r.unicode size) r.frac) - ($_ r.or r.bit (r.unicode size) r.frac) - ($_ r.and r.bit r.frac (r.unicode size)) + (do {@ random.monad} + [size (:: @ map (n.% 2) random.nat)] + ($_ random.and + random.bit + random.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) ..gen-recursive ## _instant.instant ## _duration.duration @@ -112,5 +112,6 @@ (def: #export test Test - (<| (_.context (%.name (name-of /._))) - ($codec.spec ..equivalence ..codec gen-record))) + (<| (_.covering /._) + (_.with-cover [/.codec] + ($codec.spec ..equivalence ..codec ..gen-record)))) diff --git a/stdlib/source/test/lux/macro/syntax/common.lux b/stdlib/source/test/lux/macro/syntax/common.lux new file mode 100644 index 000000000..1aaf851a9 --- /dev/null +++ b/stdlib/source/test/lux/macro/syntax/common.lux @@ -0,0 +1,134 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [math + ["." random (#+ Random)]] + [abstract + [monad (#+ do)] + ["." equivalence (#+ Equivalence)]] + [control + [pipe (#+ case>)] + ["." try] + ["<>" parser + ["<c>" code]]] + [data + ["." bit ("#@." equivalence)] + ["." name] + ["." text] + [number + ["n" nat]] + [collection + ["." list]]] + [macro + ["." code]]] + {1 + ["." / + ["#." reader] + ["#." writer]]} + ["." /// #_ + ["#." code]]) + +(def: annotations-equivalence + (Equivalence /.Annotations) + (list.equivalence + (equivalence.product name.equivalence + code.equivalence))) + +(def: random-text + (Random Text) + (random.ascii/alpha 10)) + +(def: random-name + (Random Name) + (random.and ..random-text ..random-text)) + +(def: random-annotations + (Random /.Annotations) + (do {@ random.monad} + [size (:: @ map (|>> (n.% 3)) random.nat)] + (random.list size (random.and random-name + ///code.random)))) + +(def: #export test + Test + (<| (_.covering /._) + (_.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)))) + (_.with-cover [/.Annotations] + ($_ _.and + (do random.monad + [expected ..random-annotations] + (_.cover [/reader.annotations /writer.annotations] + (|> expected + /writer.annotations list + (<c>.run /reader.annotations) + (case> (#try.Success actual) + (:: ..annotations-equivalence = expected actual) + + (#try.Failure error) + false)))) + (_.cover [/.empty-annotations] + (|> /.empty-annotations + /writer.annotations list + (<c>.run /reader.annotations) + (case> (#try.Success actual) + (:: ..annotations-equivalence = /.empty-annotations actual) + + (#try.Failure error) + false))) + )) + (do {@ random.monad} + [size (:: @ map (|>> (n.% 3)) random.nat) + expected (random.list size ..random-text)] + (_.cover [/.Type-Var /reader.type-variables /writer.type-variables] + (|> expected + /writer.type-variables + (<c>.run /reader.type-variables) + (case> (#try.Success actual) + (:: (list.equivalence text.equivalence) = expected actual) + + (#try.Failure error) + false)))) + (do {@ random.monad} + [size (:: @ map (|>> (n.% 3)) random.nat) + expected (: (Random /.Declaration) + (random.and ..random-text + (random.list size ..random-text)))] + (_.cover [/.Declaration /reader.declaration /writer.declaration] + (|> expected + /writer.declaration list + (<c>.run /reader.declaration) + (case> (#try.Success actual) + (let [equivalence (equivalence.product text.equivalence + (list.equivalence text.equivalence))] + (:: equivalence = expected actual)) + + (#try.Failure error) + false)))) + (do {@ random.monad} + [expected (: (Random /.Typed-Input) + (random.and ///code.random + ///code.random))] + (_.cover [/.Typed-Input /reader.typed-input /writer.typed-input] + (|> expected + /writer.typed-input list + (<c>.run /reader.typed-input) + (case> (#try.Success actual) + (let [equivalence (equivalence.product code.equivalence code.equivalence)] + (:: equivalence = expected actual)) + + (#try.Failure error) + false)))) + ))) |