aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/exception.lux2
-rw-r--r--stdlib/source/lux/control/parser/xml.lux43
-rw-r--r--stdlib/source/lux/data/binary.lux18
-rw-r--r--stdlib/source/lux/data/format/xml.lux9
-rw-r--r--stdlib/source/lux/data/number/i64.lux6
-rw-r--r--stdlib/source/lux/data/text.lux22
-rw-r--r--stdlib/source/lux/macro/syntax/common.lux6
-rw-r--r--stdlib/source/lux/macro/syntax/common/reader.lux4
-rw-r--r--stdlib/source/lux/macro/syntax/common/writer.lux7
-rw-r--r--stdlib/source/lux/world/net/http.lux15
-rw-r--r--stdlib/source/lux/world/net/uri.lux8
-rw-r--r--stdlib/source/poly/lux/data/format/json.lux4
-rw-r--r--stdlib/source/program/aedifex.lux94
-rw-r--r--stdlib/source/program/aedifex/artifact.lux68
-rw-r--r--stdlib/source/program/aedifex/cli.lux4
-rw-r--r--stdlib/source/program/aedifex/dependency.lux276
-rw-r--r--stdlib/source/program/aedifex/extension.lux11
-rw-r--r--stdlib/source/program/aedifex/hash.lux16
-rw-r--r--stdlib/source/program/aedifex/local.lux120
-rw-r--r--stdlib/source/program/aedifex/parser.lux15
-rw-r--r--stdlib/source/program/aedifex/pom.lux27
-rw-r--r--stdlib/source/program/aedifex/project.lux35
-rw-r--r--stdlib/source/test/lux/control/concurrency/frp.lux2
-rw-r--r--stdlib/source/test/lux/control/function/memo.lux2
-rw-r--r--stdlib/source/test/lux/macro.lux4
-rw-r--r--stdlib/source/test/lux/macro/code.lux2
-rw-r--r--stdlib/source/test/lux/macro/poly/json.lux47
-rw-r--r--stdlib/source/test/lux/macro/syntax/common.lux134
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))))
+ )))