aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux.lux8
-rw-r--r--stdlib/source/lux/control/parser/code.lux6
-rw-r--r--stdlib/source/lux/data/number/rev.lux4
-rw-r--r--stdlib/source/lux/data/text/format.lux4
-rw-r--r--stdlib/source/lux/host.old.lux20
-rw-r--r--stdlib/source/lux/macro/code.lux6
-rw-r--r--stdlib/source/lux/meta.lux4
-rw-r--r--stdlib/source/lux/type.lux22
-rw-r--r--stdlib/source/lux/type/check.lux12
-rw-r--r--stdlib/source/poly/lux/data/format/json.lux4
-rw-r--r--stdlib/source/program/aedifex/command/deploy.lux4
-rw-r--r--stdlib/source/program/aedifex/dependency.lux54
-rw-r--r--stdlib/source/program/aedifex/hash.lux164
-rw-r--r--stdlib/source/program/aedifex/local.lux8
-rw-r--r--stdlib/source/test/aedifex.lux2
-rw-r--r--stdlib/source/test/aedifex/hash.lux95
-rw-r--r--stdlib/source/test/lux/data/binary.lux8
-rw-r--r--stdlib/source/test/lux/data/collection/bits.lux128
-rw-r--r--stdlib/source/test/lux/macro/code.lux6
-rw-r--r--stdlib/source/test/lux/target/jvm.lux4
20 files changed, 383 insertions, 180 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 01401ea29..4f6a134a4 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -2206,7 +2206,7 @@
(-> Bit Text)
(if x "#1" "#0"))
-(def:''' (digit-to-text digit)
+(def:''' (digit::format digit)
#Nil
(-> Nat Text)
({0 "0"
@@ -2228,7 +2228,7 @@
(if ("lux i64 =" 0 input)
output
(recur (n// 10 input)
- (text@compose (|> input (n/% 10) digit-to-text)
+ (text@compose (|> input (n/% 10) digit::format)
output)))))]
(loop value ""))}
value))
@@ -2253,10 +2253,10 @@
(if ("lux i64 =" +0 input)
(text@compose sign output)
(recur ("lux i64 /" +10 input)
- (text@compose (|> input ("lux i64 %" +10) ("lux coerce" Nat) digit-to-text)
+ (text@compose (|> input ("lux i64 %" +10) ("lux coerce" Nat) digit::format)
output)))))
(|> value ("lux i64 /" +10) int@abs)
- (|> value ("lux i64 %" +10) int@abs ("lux coerce" Nat) digit-to-text)))))
+ (|> value ("lux i64 %" +10) int@abs ("lux coerce" Nat) digit::format)))))
(def:''' (frac@encode x)
#Nil
diff --git a/stdlib/source/lux/control/parser/code.lux b/stdlib/source/lux/control/parser/code.lux
index ca0df7c9f..f03188e15 100644
--- a/stdlib/source/lux/control/parser/code.lux
+++ b/stdlib/source/lux/control/parser/code.lux
@@ -32,7 +32,7 @@
(def: (remaining-inputs asts)
(-> (List Code) Text)
($_ text@compose text.new-line "Remaining input: "
- (|> asts (list@map code.to-text) (list.interpose " ") (text.join-with ""))))
+ (|> asts (list@map code.format) (list.interpose " ") (text.join-with ""))))
(def: #export any
{#.doc "Just returns the next input without applying any logic."}
@@ -88,7 +88,7 @@
(#.Cons [token tokens'])
(if (code@= ast token)
(#try.Success [tokens' []])
- (#try.Failure ($_ text@compose "Expected a " (code.to-text ast) " but instead got " (code.to-text token)
+ (#try.Failure ($_ text@compose "Expected a " (code.format ast) " but instead got " (code.format token)
(remaining-inputs tokens))))
_
@@ -185,7 +185,7 @@
_
(#try.Failure (text@compose "Unconsumed inputs: "
- (|> (list@map code.to-text unconsumed)
+ (|> (list@map code.format unconsumed)
(text.join-with ", ")))))))
(def: #export (local inputs syntax)
diff --git a/stdlib/source/lux/data/number/rev.lux b/stdlib/source/lux/data/number/rev.lux
index eef378a75..578f6f955 100644
--- a/stdlib/source/lux/data/number/rev.lux
+++ b/stdlib/source/lux/data/number/rev.lux
@@ -306,7 +306,7 @@
(digits::times-5! power output))
output)))
-(def: (digits::to-text digits)
+(def: (digits::format digits)
(-> Digits Text)
(loop [idx (dec //i64.width)
all-zeroes? #1
@@ -408,7 +408,7 @@
digits'))
(recur (dec idx)
digits))
- ("lux text concat" "." (digits::to-text digits))
+ ("lux text concat" "." (digits::format digits))
)))))
(def: (decode input)
diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux
index ecbdb80df..6b9de5402 100644
--- a/stdlib/source/lux/data/text/format.lux
+++ b/stdlib/source/lux/data/text/format.lux
@@ -63,8 +63,8 @@
[ratio ratio.Ratio (:: ratio.codec encode)]
[text Text text.encode]
[name Name (:: name.codec encode)]
- [code Code code.to-text]
- [type Type type.to-text]
+ [code Code code.format]
+ [type Type type.format]
[bin Nat (:: nat.binary encode)]
[oct Nat (:: nat.octal encode)]
[hex Nat (:: nat.hex encode)]
diff --git a/stdlib/source/lux/host.old.lux b/stdlib/source/lux/host.old.lux
index 9582464ba..1e05c2fb7 100644
--- a/stdlib/source/lux/host.old.lux
+++ b/stdlib/source/lux/host.old.lux
@@ -961,7 +961,7 @@
(def: (annotation-param$ [name value])
(-> AnnotationParam JVM-Code)
- (format name "=" (code.to-text value)))
+ (format name "=" (code.format value)))
(def: (annotation$ [name params])
(-> Annotation JVM-Code)
@@ -1030,7 +1030,7 @@
(spaced (list "constant" name
(with-brackets (spaced (list@map annotation$ anns)))
(generic-type$ class)
- (code.to-text value))
+ (code.format value))
))
(#VariableField sm class)
@@ -1051,7 +1051,7 @@
(def: (constructor-arg$ [class term])
(-> ConstructorArg JVM-Code)
(with-brackets
- (spaced (list (generic-type$ class) (code.to-text term)))))
+ (spaced (list (generic-type$ class) (code.format term)))))
(def: (method-def$ replacer super-class [[name pm anns] method-def])
(-> (-> Code Code) Super-Class-Decl [Member-Declaration Method-Definition] JVM-Code)
@@ -1066,7 +1066,7 @@
(with-brackets (spaced (list@map generic-type$ exs)))
(with-brackets (spaced (list@map arg-decl$ arg-decls)))
(with-brackets (spaced (list@map constructor-arg$ constructor-args)))
- (code.to-text (pre-walk-replace replacer body))
+ (code.format (pre-walk-replace replacer body))
)))
(#VirtualMethod final? strict-fp? type-vars this-name arg-decls return-type body exs)
@@ -1081,8 +1081,8 @@
(with-brackets (spaced (list@map generic-type$ exs)))
(with-brackets (spaced (list@map arg-decl$ arg-decls)))
(generic-type$ return-type)
- (code.to-text (pre-walk-replace replacer (` (let [(~ (code.local-identifier this-name)) (~' _jvm_this)]
- (~ body))))))))
+ (code.format (pre-walk-replace replacer (` (let [(~ (code.local-identifier this-name)) (~' _jvm_this)]
+ (~ body))))))))
(#OverridenMethod strict-fp? class-decl type-vars this-name arg-decls return-type body exs)
(let [super-replacer (parser->replacer (s.form (do p.monad
@@ -1109,7 +1109,7 @@
(~ body)))
(pre-walk-replace replacer)
(pre-walk-replace super-replacer)
- (code.to-text))
+ (code.format))
))))
(#StaticMethod strict-fp? type-vars arg-decls return-type body exs)
@@ -1123,7 +1123,7 @@
(with-brackets (spaced (list@map generic-type$ exs)))
(with-brackets (spaced (list@map arg-decl$ arg-decls)))
(generic-type$ return-type)
- (code.to-text (pre-walk-replace replacer body)))))
+ (code.format (pre-walk-replace replacer body)))))
(#AbstractMethod type-vars arg-decls return-type exs)
(with-parens
@@ -1731,7 +1731,7 @@
(#.Apply A F)
(case (type.apply (list A) F)
#.None
- (meta.fail (format "Cannot apply type: " (type.to-text F) " to " (type.to-text A)))
+ (meta.fail (format "Cannot apply type: " (type.format F) " to " (type.format A)))
(#.Some type')
(type->class-name type'))
@@ -1740,7 +1740,7 @@
(type->class-name type')
_
- (meta.fail (format "Cannot convert to JvmType: " (type.to-text type))))))
+ (meta.fail (format "Cannot convert to JvmType: " (type.format type))))))
(syntax: #export (array-read idx array)
{#.doc (doc "Loads an element from an array."
diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux
index c5064c480..82ccd1f9d 100644
--- a/stdlib/source/lux/macro/code.lux
+++ b/stdlib/source/lux/macro/code.lux
@@ -89,7 +89,7 @@
_
#0)))
-(def: #export (to-text ast)
+(def: #export (format ast)
(-> Code Text)
(case ast
(^template [<tag> <struct>]
@@ -113,7 +113,7 @@
($_ text@compose
<open>
(list@fold (function (_ next prev)
- (let [next (to-text next)]
+ (let [next (format next)]
(if (text@= "" prev)
next
($_ text@compose prev " " next))))
@@ -127,7 +127,7 @@
($_ text@compose
"{"
(list@fold (function (_ [left right] prev)
- (let [next ($_ text@compose (to-text left) " " (to-text right))]
+ (let [next ($_ text@compose (format left) " " (format right))]
(if (text@= "" prev)
next
($_ text@compose prev " " next))))
diff --git a/stdlib/source/lux/meta.lux b/stdlib/source/lux/meta.lux
index 1155eaf93..6991ec840 100644
--- a/stdlib/source/lux/meta.lux
+++ b/stdlib/source/lux/meta.lux
@@ -296,7 +296,7 @@
(:: ..monad wrap name)
_
- (fail (text@compose "Code is not a local identifier: " (code.to-text ast)))))
+ (fail (text@compose "Code is not a local identifier: " (code.format ast)))))
(def: #export wrong-syntax-error
(-> Name Text)
@@ -687,7 +687,7 @@
[location ..location
output (<func> token)
#let [_ (log! ($_ text@compose (name@encode (name-of <macro>)) " @ " (location.format location)))
- _ (list@map (|>> code.to-text log!)
+ _ (list@map (|>> code.format log!)
output)
_ (log! "")]]
(wrap (if omit?
diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux
index 8da9421e4..81ce70e3d 100644
--- a/stdlib/source/lux/type.lux
+++ b/stdlib/source/lux/type.lux
@@ -73,7 +73,7 @@
[flatten-tuple #.Product]
)
-(def: #export (to-text type)
+(def: #export (format type)
(-> Type Text)
(case type
(#.Primitive name params)
@@ -81,7 +81,7 @@
"(primitive "
(text.enclose' text.double-quote name)
(|> params
- (list@map (|>> to-text (text@compose " ")))
+ (list@map (|>> format (text@compose " ")))
(list@fold (function.flip text@compose) ""))
")")
@@ -89,7 +89,7 @@
(<tag> _)
($_ text@compose <open>
(|> (<flatten> type)
- (list@map to-text)
+ (list@map format)
list.reverse
(list.interpose " ")
(list@fold text@compose ""))
@@ -101,11 +101,11 @@
(let [[ins out] (flatten-function type)]
($_ text@compose "(-> "
(|> ins
- (list@map to-text)
+ (list@map format)
list.reverse
(list.interpose " ")
(list@fold text@compose ""))
- " " (to-text out) ")"))
+ " " (format out) ")"))
(#.Parameter idx)
(n@encode idx)
@@ -118,11 +118,11 @@
(#.Apply param fun)
(let [[type-func type-args] (flatten-application type)]
- ($_ text@compose "(" (to-text type-func) " " (|> type-args (list@map to-text) list.reverse (list.interpose " ") (list@fold text@compose "")) ")"))
+ ($_ text@compose "(" (format type-func) " " (|> type-args (list@map format) list.reverse (list.interpose " ") (list@fold text@compose "")) ")"))
(^template [<tag> <desc>]
(<tag> env body)
- ($_ text@compose "(" <desc> " {" (|> env (list@map to-text) (text.join-with " ")) "} " (to-text body) ")"))
+ ($_ text@compose "(" <desc> " {" (|> env (list@map format) (text.join-with " ")) "} " (format body) ")"))
([#.UnivQ "All"]
[#.ExQ "Ex"])
@@ -162,7 +162,7 @@
(list@map (.function (_ [index type])
($_ text@compose
(n@encode index)
- " " (..to-text type))))
+ " " (..format type))))
(text.join-with (text@compose text.new-line " ")))))
(list.nth idx env))
@@ -373,12 +373,12 @@
(name@encode (name-of ..:log!)) " " (location.format location) text.new-line
"Expression: " (case valueC
(#.Some valueC)
- (code.to-text valueC)
+ (code.format valueC)
#.None
(name@encode valueN))
text.new-line
- " Type: " (..to-text valueT)))]]
+ " Type: " (..format valueT)))]]
(wrap (list (code.identifier valueN))))
(#.Right valueC)
@@ -437,7 +437,7 @@
(exception: #export (hole-type {location Location} {type Type})
(exception.report
["Location" (location.format location)]
- ["Type" (..to-text type)]))
+ ["Type" (..format type)]))
(syntax: #export (:hole)
(do meta.monad
diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux
index 98a463948..7ca34e7de 100644
--- a/stdlib/source/lux/type/check.lux
+++ b/stdlib/source/lux/type/check.lux
@@ -34,19 +34,19 @@
(exception: #export (invalid-type-application {funcT Type} {argT Type})
(exception.report
- ["Type function" (//.to-text funcT)]
- ["Type argument" (//.to-text argT)]))
+ ["Type function" (//.format funcT)]
+ ["Type argument" (//.format argT)]))
(exception: #export (cannot-rebind-var {id Nat} {type Type} {bound Type})
(exception.report
["Var" (n@encode id)]
- ["Wanted Type" (//.to-text type)]
- ["Current Type" (//.to-text bound)]))
+ ["Wanted Type" (//.format type)]
+ ["Current Type" (//.format bound)]))
(exception: #export (type-check-failed {expected Type} {actual Type})
(exception.report
- ["Expected" (//.to-text expected)]
- ["Actual" (//.to-text actual)]))
+ ["Expected" (//.format expected)]
+ ["Actual" (//.format actual)]))
(type: #export Var Nat)
diff --git a/stdlib/source/poly/lux/data/format/json.lux b/stdlib/source/poly/lux/data/format/json.lux
index cae14c54b..1f9234a4d 100644
--- a/stdlib/source/poly/lux/data/format/json.lux
+++ b/stdlib/source/poly/lux/data/format/json.lux
@@ -217,7 +217,7 @@
<type>.parameter
<type>.recursive-call
## If all else fails...
- (p.fail (format "Cannot create JSON encoder for: " (type.to-text inputT)))
+ (p.fail (format "Cannot create JSON encoder for: " (type.format inputT)))
))))
(poly: #export codec//decode
@@ -319,7 +319,7 @@
<type>.parameter
<type>.recursive-call
## If all else fails...
- (p.fail (format "Cannot create JSON decoder for: " (type.to-text inputT)))
+ (p.fail (format "Cannot create JSON decoder for: " (type.format inputT)))
))))
(syntax: #export (codec inputT)
diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux
index a4b076733..b63aa2972 100644
--- a/stdlib/source/program/aedifex/command/deploy.lux
+++ b/stdlib/source/program/aedifex/command/deploy.lux
@@ -69,6 +69,6 @@
pom (promise@wrap (///pom.project profile))
_ (deploy! ///artifact/type.pom (|> pom (:: xml.codec encode) encoding.to-utf8))
_ (deploy! ///artifact/type.lux-library library)
- _ (deploy! "sha1" (///hash.sha1 library))
- _ (deploy! "md5" (///hash.md5 library))]
+ _ (deploy! "sha1" (///hash.data (///hash.sha1 library)))
+ _ (deploy! "md5" (///hash.data (///hash.md5 library)))]
(wrap [])))))
diff --git a/stdlib/source/program/aedifex/dependency.lux b/stdlib/source/program/aedifex/dependency.lux
index 52a1f00c5..de6a1e4cf 100644
--- a/stdlib/source/program/aedifex/dependency.lux
+++ b/stdlib/source/program/aedifex/dependency.lux
@@ -2,6 +2,7 @@
[lux (#- Name)
["." host (#+ import:)]
[abstract
+ [codec (#+ Codec)]
[monad (#+ do)]
["." equivalence (#+ Equivalence)]
["." hash (#+ Hash)]]
@@ -93,40 +94,6 @@
[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)
@@ -149,18 +116,21 @@
#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)))
+(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 [reference (hash library)]
+ [#let [expected (hash library)]
actual (..download url)]
(:: io.monad wrap
(do try.monad
[output (encoding.from-utf8 actual)
- actual (reader actual)
+ actual (:: codec decode output)
_ (exception.assert exception [dependency output]
- (:: binary.equivalence = reference actual))]
+ (:: //hash.equivalence = expected actual))]
(wrap output)))))
(def: parse-property
@@ -220,8 +190,8 @@
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 ..sha1 ..sha1-does-not-match)
- md5 (..verified-hash dependency library (format prefix //artifact/extension.md5) //hash.md5 ..md5 ..md5-does-not-match)
+ 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
diff --git a/stdlib/source/program/aedifex/hash.lux b/stdlib/source/program/aedifex/hash.lux
index 86fe4319d..2f63d0edd 100644
--- a/stdlib/source/program/aedifex/hash.lux
+++ b/stdlib/source/program/aedifex/hash.lux
@@ -1,12 +1,23 @@
(.module:
[lux #*
["." host (#+ import:)]
+ [abstract
+ [codec (#+ Codec)]
+ [equivalence (#+ Equivalence)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
[data
["." binary (#+ Binary)]
["." text
- ["%" format (#+ format)]]
+ ["%" format (#+ Format format)]
+ ["." encoding]]
[number
- ["." nat]]]])
+ ["." i64]
+ ["n" nat]]]
+ [type
+ abstract]])
## TODO: Replace with pure-Lux implementations of these algorithms
## https://en.wikipedia.org/wiki/SHA-1#SHA-1_pseudocode
@@ -17,25 +28,136 @@
(#static getInstance [java/lang/String] java/security/MessageDigest)
(digest [[byte]] [byte]))
-(type: #export Hash
- Binary)
+(abstract: #export SHA-1 Any)
+(abstract: #export MD5 Any)
-(template [<name> <algorithm>]
- [(def: #export (<name> value)
- (-> Binary Hash)
- (|> (java/security/MessageDigest::getInstance [<algorithm>])
- (java/security/MessageDigest::digest [value])))]
+(abstract: #export (Hash h)
+ Binary
- [sha1 "SHA-1"]
- [md5 "MD5"]
- )
+ (def: #export data
+ (All [h] (-> (Hash h) Binary))
+ (|>> :representation))
+
+ (template [<name> <kind> <algorithm>]
+ [(def: #export (<name> value)
+ (-> Binary (Hash <kind>))
+ (|> (java/security/MessageDigest::getInstance [<algorithm>])
+ (java/security/MessageDigest::digest [value])
+ :abstraction))]
+
+ [sha1 ..SHA-1 "SHA-1"]
+ [md5 ..MD5 "MD5"]
+ )
+
+ (def: encode
+ (Format Binary)
+ (binary.fold (function (_ byte representation)
+ (let [hex (:: n.hex encode byte)
+ hex (case (text.size hex)
+ 1 (format "0" hex)
+ _ hex)]
+ (format representation hex)))
+ ""))
+
+ (template [<factor> <name>]
+ [(def: <name>
+ Nat
+ <factor>)]
+
+ [20 sha1::size]
+ [16 md5::size]
+ )
+
+ (def: hex-per-byte
+ 2)
+
+ (def: hex-per-chunk
+ (n.* hex-per-byte i64.bytes-per-i64))
+
+ (exception: #export (not-a-hash {size Nat} {value Text})
+ (exception.report
+ ["Pseudo hash" (%.text value)]
+ ["Expected size" (%.nat size)]
+ ["Actual size" (%.nat (text.size value))]))
+
+ (template [<name> <size>]
+ [(exception: #export (<name> {data Binary})
+ (exception.report
+ ["Pseudo hash" (%.text (..encode data))]
+ ["Expected size" (%.nat <size>)]
+ ["Actual size" (%.nat (binary.size data))]))]
+
+ [not-a-sha1 ..sha1::size]
+ [not-a-md5 ..md5::size]
+ )
-(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)))
- ""))
+ (template [<name> <kind> <size> <exception>]
+ [(def: #export (<name> data)
+ (-> Binary (Try (Hash <kind>)))
+ (if (n.= <size> (binary.size data))
+ (#try.Success (:abstraction data))
+ (exception.throw <exception> [data])))]
+
+ [as-sha1 SHA-1 ..sha1::size ..not-a-sha1]
+ [as-md5 MD5 ..md5::size ..not-a-md5]
+ )
+
+ (def: hash-size
+ (-> Text Nat)
+ (|>> text.size (n./ ..hex-per-byte)))
+
+ (def: encoding-size
+ (-> Nat Nat)
+ (n.* ..hex-per-byte))
+
+ (def: (decode size constructor encoded)
+ (All [h]
+ (-> Nat (-> Binary (Try (Hash h)))
+ (-> Text (Try (Hash h)))))
+ (let [hash-size (..hash-size encoded)]
+ (if (n.= size hash-size)
+ (loop [input encoded
+ chunk 0
+ output (binary.create hash-size)]
+ (let [index (n.* chunk i64.bytes-per-i64)]
+ (case (text.split ..hex-per-chunk input)
+ (#.Some [head tail])
+ (do try.monad
+ [head (:: n.hex decode head)
+ output (binary.write/64 index head output)]
+ (recur tail (inc chunk) output))
+
+ #.None
+ (case (..hash-size input)
+ 0 (constructor output)
+ (^template [<size> <write>]
+ <size>
+ (do try.monad
+ [head (:: n.hex decode input)
+ output (<write> index head output)]
+ (constructor output)))
+ ([1 binary.write/8]
+ [2 binary.write/16]
+ [4 binary.write/32])
+ _ (exception.throw ..not-a-hash [(..encoding-size size) encoded])))))
+ (exception.throw ..not-a-hash [(..encoding-size size) encoded]))))
+
+ (template [<codec> <hash> <nat> <constructor>]
+ [(structure: #export <codec>
+ (Codec Text (Hash <hash>))
+
+ (def: encode (|>> :representation ..encode))
+ (def: decode (..decode <nat> <constructor>)))]
+
+ [sha1-codec SHA-1 ..sha1::size ..as-sha1]
+ [md5-codec MD5 ..md5::size ..as-md5]
+ )
+
+ (structure: #export equivalence
+ (All [h] (Equivalence (Hash h)))
+
+ (def: (= reference subject)
+ (:: binary.equivalence =
+ (:representation reference)
+ (:representation subject))))
+ )
diff --git a/stdlib/source/program/aedifex/local.lux b/stdlib/source/program/aedifex/local.lux
index affbb659e..626996ef3 100644
--- a/stdlib/source/program/aedifex/local.lux
+++ b/stdlib/source/program/aedifex/local.lux
@@ -141,8 +141,12 @@
(wrap {#//dependency.library library
#//dependency.pom pom
#//dependency.dependencies dependencies
- #//dependency.sha1 (//hash.representation sha1)
- #//dependency.md5 (//hash.representation md5)})))
+ #//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))})))
(def: #export (all-cached system dependencies resolution)
(-> (file.System Promise) (List Dependency) Resolution (Promise (Try Resolution)))
diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux
index 48ecc9189..c496eb88b 100644
--- a/stdlib/source/test/aedifex.lux
+++ b/stdlib/source/test/aedifex.lux
@@ -10,6 +10,7 @@
["#." profile]
["#." project]
["#." cli]
+ ["#." hash]
["#." parser]])
(def: test
@@ -19,6 +20,7 @@
/profile.test
/project.test
/cli.test
+ /hash.test
/parser.test
))
diff --git a/stdlib/source/test/aedifex/hash.lux b/stdlib/source/test/aedifex/hash.lux
new file mode 100644
index 000000000..21e318be6
--- /dev/null
+++ b/stdlib/source/test/aedifex/hash.lux
@@ -0,0 +1,95 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]
+ {[0 #spec]
+ [/
+ ["$." equivalence]
+ ["$." codec]]}]
+ [control
+ ["." try]
+ ["." exception]]
+ [data
+ ["." binary (#+ Binary)]
+ [number
+ ["n" nat]]
+ [text
+ ["%" format (#+ format)]]]
+ [math
+ ["." random (#+ Random)]]]
+ {#program
+ ["." /]}
+ [test
+ [lux
+ [data
+ ["_." binary]]]])
+
+(def: (random hash)
+ (All [h]
+ (-> (-> Binary (/.Hash h))
+ (Random (/.Hash h))))
+ (do {@ random.monad}
+ [size (:: @ map (n.% 100) random.nat)]
+ (:: @ map hash (_binary.random size))))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ (_.with-cover [/.Hash /.SHA-1 /.MD5])
+ (`` ($_ _.and
+ (_.with-cover [/.equivalence]
+ ($_ _.and
+ ($equivalence.spec /.equivalence (..random /.sha1))
+ ($equivalence.spec /.equivalence (..random /.md5))
+ ))
+ (_.with-cover [/.data]
+ ($_ _.and
+ (~~ (template [<hash> <constructor> <exception>]
+ [(do random.monad
+ [expected (..random <hash>)]
+ (_.cover [<hash> <constructor> <exception>]
+ (and (case (<constructor> (/.data expected))
+ (#try.Success actual)
+ (:: /.equivalence = expected actual)
+
+ (#try.Failure error)
+ false)
+ (case (<constructor> (:: binary.monoid compose
+ (/.data expected)
+ (/.data expected)))
+ (#try.Success actual)
+ false
+
+ (#try.Failure error)
+ (exception.match? <exception> error)))))]
+
+ [/.sha1 /.as-sha1 /.not-a-sha1]
+ [/.md5 /.as-md5 /.not-a-md5]
+ ))))
+ (~~ (template [<codec> <hash>]
+ [(_.with-cover [<codec>]
+ ($codec.spec /.equivalence <codec> (..random <hash>)))]
+
+ [/.sha1-codec /.sha1]
+ [/.md5-codec /.md5]
+ ))
+ (_.with-cover [/.not-a-hash]
+ ($_ _.and
+ (~~ (template [<codec> <hash>]
+ [(do random.monad
+ [expected (..random <hash>)]
+ (_.cover [<codec>]
+ (case (:: <codec> decode
+ (format (:: <codec> encode expected)
+ "AABBCC"))
+ (#try.Success actual)
+ false
+
+ (#try.Failure error)
+ (exception.match? /.not-a-hash error))))]
+
+ [/.sha1-codec /.sha1]
+ [/.md5-codec /.md5]
+ ))))
+ ))))
diff --git a/stdlib/source/test/lux/data/binary.lux b/stdlib/source/test/lux/data/binary.lux
index 17f773206..c011df720 100644
--- a/stdlib/source/test/lux/data/binary.lux
+++ b/stdlib/source/test/lux/data/binary.lux
@@ -31,7 +31,7 @@
(#try.Success output)
output))
-(def: #export (binary size)
+(def: #export (random size)
(-> Nat (Random Binary))
(let [output (/.create size)]
(loop [idx 0]
@@ -80,7 +80,7 @@
(do {@ random.monad}
[#let [gen-size (|> random.nat (:: @ map (|>> (n.% 100) (n.max 8))))]
size gen-size
- sample (..binary size)
+ sample (..random size)
value random.nat
#let [gen-idx (|> random.nat (:: @ map (n.% size)))]
[from to] (random.and gen-idx gen-idx)
@@ -88,9 +88,9 @@
(_.with-cover [/.Binary]
($_ _.and
(_.with-cover [/.equivalence]
- ($equivalence.spec /.equivalence (..binary size)))
+ ($equivalence.spec /.equivalence (..random size)))
(_.with-cover [/.monoid]
- ($monoid.spec /.equivalence /.monoid (..binary size)))
+ ($monoid.spec /.equivalence /.monoid (..random size)))
(_.cover [/.fold]
(n.= (:: list.fold fold n.+ 0 (..as-list sample))
(/.fold n.+ 0 sample)))
diff --git a/stdlib/source/test/lux/data/collection/bits.lux b/stdlib/source/test/lux/data/collection/bits.lux
index 59d7e3443..166ced163 100644
--- a/stdlib/source/test/lux/data/collection/bits.lux
+++ b/stdlib/source/test/lux/data/collection/bits.lux
@@ -1,6 +1,5 @@
(.module:
[lux #*
- ["%" data/text/format (#+ format)]
["_" test (#+ Test)]
[abstract
[monad (#+ do)]
@@ -12,74 +11,85 @@
[number
["n" nat]]]
[math
- ["r" random (#+ Random)]]]
+ ["." random (#+ Random)]]]
{1
["." / (#+ Bits)]})
(def: (size min max)
(-> Nat Nat (Random Nat))
- (|> r.nat
- (:: r.monad map (|>> (n.% max) (n.max min)))))
+ (|> random.nat
+ (:: random.monad map (|>> (n.% (inc max)) (n.max min)))))
-(def: #export bits
+(def: #export random
(Random Bits)
- (do {@ r.monad}
- [size (size 1 1,000)
- idx (|> r.nat (:: @ map (n.% size)))]
- (wrap (|> /.empty (/.set idx)))))
+ (do {@ random.monad}
+ [size (:: @ map (n.% 1,000) random.nat)]
+ (case size
+ 0 (wrap /.empty)
+ _ (do {@ random.monad}
+ [idx (|> random.nat (:: @ map (n.% size)))]
+ (wrap (/.set idx /.empty))))))
(def: #export test
Test
- (<| (_.context (%.name (name-of /._)))
+ (<| (_.covering /._)
+ (_.with-cover [/.Bits])
($_ _.and
- ($equivalence.spec /.equivalence ..bits)
- (do {@ r.monad}
- [size (size 1 1,000)
- idx (|> r.nat (:: @ map (n.% size)))
- sample bits]
+ (_.with-cover [/.equivalence]
+ ($equivalence.spec /.equivalence ..random))
+
+ (do random.monad
+ [sample ..random]
+ (_.cover [/.empty? /.size]
+ (if (/.empty? sample)
+ (n.= 0 (/.size sample))
+ (n.> 0 (/.size sample)))))
+ (_.cover [/.empty]
+ (/.empty? /.empty))
+
+ (do {@ random.monad}
+ [size (:: @ map (|>> (n.% 1,000) inc) random.nat)
+ idx (:: @ map (n.% size) random.nat)
+ sample ..random]
($_ _.and
- (_.test "Can set individual bits."
- (and (|> /.empty (/.get idx) not)
- (|> /.empty (/.set idx) (/.get idx))))
- (_.test "Can clear individual bits."
- (|> /.empty (/.set idx) (/.clear idx) (/.get idx) not))
- (_.test "Can flip individual bits."
- (and (|> /.empty (/.flip idx) (/.get idx))
- (|> /.empty (/.flip idx) (/.flip idx) (/.get idx) not)))
- (_.test "Bits (only) grow when (and as much as) necessary."
- (and (n.= 0 (/.capacity /.empty))
- (|> /.empty (/.set idx) /.capacity
- (n.- idx)
- (predicate.unite (n.>= 0)
- (n.< /.chunk-size)))))
- (_.test "Bits (must) shrink when (and as much as) possible."
- (let [grown (/.flip idx /.empty)]
- (and (n.> 0 (/.capacity grown))
- (is? /.empty (/.flip idx grown)))))
- (_.test "Intersection can be detected when there are set bits in common."
- (and (not (/.intersects? /.empty
- /.empty))
- (/.intersects? (/.set idx /.empty)
- (/.set idx /.empty))
- (not (/.intersects? (/.set (inc idx) /.empty)
- (/.set idx /.empty)))))
- (_.test "Cannot intersect with one's opposite."
- (not (/.intersects? sample (/.not sample))))
- (_.test "'and' with oneself changes nothing"
- (:: /.equivalence = sample (/.and sample sample)))
- (_.test "'and' with one's opposite yields the empty bit-set."
- (is? /.empty (/.and sample (/.not sample))))
-
- (_.test "'or' with one's opposite fully saturates a bit-set."
- (n.= (/.size (/.or sample (/.not sample)))
- (/.capacity sample)))
- (_.test "'xor' with oneself yields the empty bit-set."
- (is? /.empty (/.xor sample sample)))
- (_.test "'xor' with one's opposite fully saturates a bit-set."
- (n.= (/.size (/.xor sample (/.not sample)))
- (/.capacity sample)))
- (_.test "Double negation results in original bit-set."
- (:: /.equivalence = sample (/.not (/.not sample))))
- (_.test "Negation does not affect the empty bit-set."
- (is? /.empty (/.not /.empty)))
+ (_.cover [/.get /.set]
+ (and (|> /.empty (/.get idx) not)
+ (|> /.empty (/.set idx) (/.get idx))))
+ (_.cover [/.clear]
+ (|> /.empty (/.set idx) (/.clear idx) (/.get idx) not))
+ (_.cover [/.flip]
+ (and (|> /.empty (/.flip idx) (/.get idx))
+ (|> /.empty (/.flip idx) (/.flip idx) (/.get idx) not)))
+ (_.cover [/.Chunk /.capacity /.chunk-size]
+ (and (n.= 0 (/.capacity /.empty))
+ (|> /.empty (/.set idx) /.capacity
+ (n.- idx)
+ (predicate.unite (n.>= 0)
+ (n.< /.chunk-size)))
+ (let [grown (/.flip idx /.empty)]
+ (and (n.> 0 (/.capacity grown))
+ (is? /.empty (/.flip idx grown))))))
+ (_.cover [/.intersects?]
+ (and (not (/.intersects? /.empty
+ /.empty))
+ (/.intersects? (/.set idx /.empty)
+ (/.set idx /.empty))
+ (not (/.intersects? (/.set (inc idx) /.empty)
+ (/.set idx /.empty)))
+ (not (/.intersects? sample (/.not sample)))))
+ (_.cover [/.not]
+ (and (not (:: /.equivalence = sample (/.not sample)))
+ (:: /.equivalence = sample (/.not (/.not sample)))
+ (is? /.empty (/.not /.empty))))
+ (_.cover [/.xor]
+ (and (is? /.empty (/.xor sample sample))
+ (n.= (/.size (/.xor sample (/.not sample)))
+ (/.capacity sample))))
+ (_.cover [/.or]
+ (and (:: /.equivalence = sample (/.or sample sample))
+ (n.= (/.size (/.or sample (/.not sample)))
+ (/.capacity sample))))
+ (_.cover [/.and]
+ (and (:: /.equivalence = sample (/.and sample sample))
+ (is? /.empty (/.and sample (/.not sample)))))
)))))
diff --git a/stdlib/source/test/lux/macro/code.lux b/stdlib/source/test/lux/macro/code.lux
index 717d4be94..9b85a557c 100644
--- a/stdlib/source/test/lux/macro/code.lux
+++ b/stdlib/source/test/lux/macro/code.lux
@@ -119,13 +119,13 @@
($_ _.and
(_.with-cover [/.equivalence]
($equivalence.spec /.equivalence ..random))
- (_.with-cover [/.to-text]
+ (_.with-cover [/.format]
(`` ($_ _.and
(~~ (template [<coverage> <random> <tag>]
[(do {@ random.monad}
[expected <random>]
(_.cover [<coverage>]
- (and (case (..read (/.to-text (<coverage> expected)))
+ (and (case (..read (/.format (<coverage> expected)))
(#try.Success actual)
(:: /.equivalence =
actual
@@ -152,7 +152,7 @@
[(do {@ random.monad}
[expected <random>]
(_.cover [<coverage>]
- (and (case (..read (/.to-text (<coverage> expected)))
+ (and (case (..read (/.format (<coverage> expected)))
(#try.Success actual)
(:: /.equivalence =
actual
diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux
index 7df1cdd07..4eefd9e03 100644
--- a/stdlib/source/test/lux/target/jvm.lux
+++ b/stdlib/source/test/lux/target/jvm.lux
@@ -982,7 +982,7 @@
@.jvm
(|>> (:coerce java/lang/Long) "jvm object cast" ("jvm long =" ("jvm object cast" (:coerce java/lang/Long expected))))}))))
(_.context "float"
- (array (/.newarray /instruction.t-float) $Float::random $Float::literal [/.fastore /.faload $Float::wrap]
+ (array (/.newarray /instruction.t-float) ..valid-float $Float::literal [/.fastore /.faload $Float::wrap]
(function (_ expected)
(for {@.old
(|>> (:coerce java/lang/Float) ("jvm feq" expected))
@@ -990,7 +990,7 @@
@.jvm
(|>> (:coerce java/lang/Float) "jvm object cast" ("jvm float =" ("jvm object cast" (:coerce java/lang/Float expected))))}))))
(_.context "double"
- (array (/.newarray /instruction.t-double) $Double::random $Double::literal [/.dastore /.daload $Double::wrap]
+ (array (/.newarray /instruction.t-double) ..valid-double $Double::literal [/.dastore /.daload $Double::wrap]
(function (_ expected)
(for {@.old
(|>> (:coerce java/lang/Double) ("jvm deq" expected))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-24 00:33:15 +0000