From c006a5fe8e82f6fc7c8cdb9db0f44c06d229f34e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 15 Oct 2020 01:01:21 -0400 Subject: Re-named "to-text" functions to "format". --- stdlib/source/lux.lux | 8 +- stdlib/source/lux/control/parser/code.lux | 6 +- stdlib/source/lux/data/number/rev.lux | 4 +- stdlib/source/lux/data/text/format.lux | 4 +- stdlib/source/lux/host.old.lux | 20 +-- stdlib/source/lux/macro/code.lux | 6 +- stdlib/source/lux/meta.lux | 4 +- stdlib/source/lux/type.lux | 22 +-- stdlib/source/lux/type/check.lux | 12 +- stdlib/source/poly/lux/data/format/json.lux | 4 +- stdlib/source/program/aedifex/command/deploy.lux | 4 +- stdlib/source/program/aedifex/dependency.lux | 54 ++------ stdlib/source/program/aedifex/hash.lux | 164 ++++++++++++++++++++--- stdlib/source/program/aedifex/local.lux | 8 +- stdlib/source/test/aedifex.lux | 2 + stdlib/source/test/aedifex/hash.lux | 95 +++++++++++++ stdlib/source/test/lux/data/binary.lux | 8 +- stdlib/source/test/lux/data/collection/bits.lux | 128 ++++++++++-------- stdlib/source/test/lux/macro/code.lux | 6 +- stdlib/source/test/lux/target/jvm.lux | 4 +- 20 files changed, 383 insertions(+), 180 deletions(-) create mode 100644 stdlib/source/test/aedifex/hash.lux 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 [ ] @@ -113,7 +113,7 @@ ($_ text@compose (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 ( token) #let [_ (log! ($_ text@compose (name@encode (name-of )) " @ " (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 @@ ( _) ($_ text@compose (|> ( 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 [ ] ( env body) - ($_ text@compose "(" " {" (|> env (list@map to-text) (text.join-with " ")) "} " (to-text body) ")")) + ($_ text@compose "(" " {" (|> 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 @@ .parameter .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 @@ .parameter .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 [] [(exception: #export ( {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 [ ] - [(def: #export ( value) - (-> Binary Hash) - (|> (java/security/MessageDigest::getInstance []) - (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 [ ] + [(def: #export ( value) + (-> Binary (Hash )) + (|> (java/security/MessageDigest::getInstance []) + (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 [ ] + [(def: + Nat + )] + + [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 [ ] + [(exception: #export ( {data Binary}) + (exception.report + ["Pseudo hash" (%.text (..encode data))] + ["Expected size" (%.nat )] + ["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 [ ] + [(def: #export ( data) + (-> Binary (Try (Hash ))) + (if (n.= (binary.size data)) + (#try.Success (:abstraction data)) + (exception.throw [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 [ ] + + (do try.monad + [head (:: n.hex decode input) + output ( 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 [ ] + [(structure: #export + (Codec Text (Hash )) + + (def: encode (|>> :representation ..encode)) + (def: decode (..decode )))] + + [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 [ ] + [(do random.monad + [expected (..random )] + (_.cover [ ] + (and (case ( (/.data expected)) + (#try.Success actual) + (:: /.equivalence = expected actual) + + (#try.Failure error) + false) + (case ( (:: binary.monoid compose + (/.data expected) + (/.data expected))) + (#try.Success actual) + false + + (#try.Failure error) + (exception.match? error)))))] + + [/.sha1 /.as-sha1 /.not-a-sha1] + [/.md5 /.as-md5 /.not-a-md5] + )))) + (~~ (template [ ] + [(_.with-cover [] + ($codec.spec /.equivalence (..random )))] + + [/.sha1-codec /.sha1] + [/.md5-codec /.md5] + )) + (_.with-cover [/.not-a-hash] + ($_ _.and + (~~ (template [ ] + [(do random.monad + [expected (..random )] + (_.cover [] + (case (:: decode + (format (:: 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 [ ] [(do {@ random.monad} [expected ] (_.cover [] - (and (case (..read (/.to-text ( expected))) + (and (case (..read (/.format ( expected))) (#try.Success actual) (:: /.equivalence = actual @@ -152,7 +152,7 @@ [(do {@ random.monad} [expected ] (_.cover [] - (and (case (..read (/.to-text ( expected))) + (and (case (..read (/.format ( 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)) -- cgit v1.2.3