From d77ce19bf01a009cf5255e0a5d8201d8cc2f2178 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 18 Aug 2020 23:44:12 -0400 Subject: Calculate SHA-1 and MD5 hashes. --- stdlib/source/lux/macro/code.lux | 1 + .../language/lux/phase/extension/analysis/jvm.lux | 6 +- stdlib/source/program/aedifex/dependency.lux | 4 +- stdlib/source/program/aedifex/hash.lux | 27 +++ stdlib/source/program/compositor.lux | 1 - stdlib/source/test/lux/control/concurrency/frp.lux | 2 +- stdlib/source/test/lux/control/function/memo.lux | 2 +- stdlib/source/test/lux/macro/code.lux | 211 ++++++++++++++++----- stdlib/source/test/lux/target/jvm.lux | 37 ++-- 9 files changed, 220 insertions(+), 71 deletions(-) create mode 100644 stdlib/source/program/aedifex/hash.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux index f91b0e51a..3f7e5f970 100644 --- a/stdlib/source/lux/macro/code.lux +++ b/stdlib/source/lux/macro/code.lux @@ -18,6 +18,7 @@ ## (#.Bit Bit) ## (#.Nat Nat) ## (#.Int Int) +## (#.Rev Rev) ## (#.Frac Frac) ## (#.Text Text) ## (#.Identifier Name) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux index 4735f8d3f..d8bf5f17b 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -213,9 +213,9 @@ (///bundle.install "and" (//lux.binary )) (///bundle.install "or" (//lux.binary )) (///bundle.install "xor" (//lux.binary )) - (///bundle.install "shl" (//lux.binary ..int )) - (///bundle.install "shr" (//lux.binary ..int )) - (///bundle.install "ushr" (//lux.binary ..int )) + (///bundle.install "shl" (//lux.binary ..int )) + (///bundle.install "shr" (//lux.binary ..int )) + (///bundle.install "ushr" (//lux.binary ..int )) )))] [bundle::int reflection.int ..int] diff --git a/stdlib/source/program/aedifex/dependency.lux b/stdlib/source/program/aedifex/dependency.lux index 13e30028b..473d5498e 100644 --- a/stdlib/source/program/aedifex/dependency.lux +++ b/stdlib/source/program/aedifex/dependency.lux @@ -1,5 +1,7 @@ (.module: - [lux (#- Type)]) + [lux (#- Type)] + ["." // #_ + ["#." hash]]) ## https://maven.apache.org/ref/3.6.3/maven-core/artifact-handlers.html (type: #export Type diff --git a/stdlib/source/program/aedifex/hash.lux b/stdlib/source/program/aedifex/hash.lux new file mode 100644 index 000000000..bd4396006 --- /dev/null +++ b/stdlib/source/program/aedifex/hash.lux @@ -0,0 +1,27 @@ +(.module: + [lux #* + ["." host (#+ import:)] + [data + ["." binary (#+ Binary)]]]) + +## TODO: Replace with pure-Lux implementations of these algorithms +## https://en.wikipedia.org/wiki/SHA-1#SHA-1_pseudocode +## https://en.wikipedia.org/wiki/MD5#Algorithm +(import: #long java/lang/String) + +(import: #long java/security/MessageDigest + (#static getInstance [java/lang/String] java/security/MessageDigest) + (digest [[byte]] [byte])) + +(type: #export Hash + Binary) + +(template [ ] + [(def: #export ( value) + (-> Binary Hash) + (|> (java/security/MessageDigest::getInstance []) + (java/security/MessageDigest::digest [value])))] + + [sha1 "SHA-1"] + [md5 "MD5"] + ) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index d551f61f2..1b17a4de8 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -149,7 +149,6 @@ (<| (or-crash! "Export failed:") (do (try.with promise.monad) [_ (/export.export (get@ #platform.&file-system platform) - (get@ #/static.host-module-extension static) export)] (wrap (log! "Export complete!")))) diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux index fe082cda7..4d9632b8c 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.* 2 polling-delay) + wiggle-room (n.* 3 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 d09625d79..564e37a87 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.+ 21))))]) + [input (|> random.nat (:: @ map (|>> (n.% 5) (n.+ 22))))]) (_.with-cover [/.Memo]) ($_ _.and (_.cover [/.closed /.none] diff --git a/stdlib/source/test/lux/macro/code.lux b/stdlib/source/test/lux/macro/code.lux index cc2d8012d..0fc1c24be 100644 --- a/stdlib/source/test/lux/macro/code.lux +++ b/stdlib/source/test/lux/macro/code.lux @@ -1,54 +1,177 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] - [abstract/monad (#+ do)] - ["r" math/random (#+ Random)] ["_" test (#+ Test)] + [math + ["." random (#+ Random) ("#@." monad)]] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence]]}] + [control + ["." try (#+ Try)]] [data - ["." text ("#@." equivalence)] + ["." product] + ["." text] [number - ["i" int] - ["f" frac]]]] + ["n" nat]] + [collection + ["." list ("#@." functor)]]] + [tool + [compiler + [language + [lux + ["." syntax]]]]]] {1 ["." /]}) +(def: random-text + (Random Text) + (random.ascii/alpha 10)) + +(def: random-name + (Random Name) + (random.and ..random-text ..random-text)) + +(def: (random-sequence random) + (All [a] (-> (Random a) (Random (List a)))) + (do {@ random.monad} + [size (|> random.nat (:: @ map (n.% 3)))] + (random.list size random))) + +(def: (random-record random) + (All [a] (-> (Random a) (Random (List [a a])))) + (do {@ random.monad} + [size (|> random.nat (:: @ map (n.% 3)))] + (random.list size (random.and random random)))) + +(def: random + (Random Code) + (random.rec + (function (_ random) + ($_ random.either + (random@map /.bit random.bit) + (random@map /.nat random.nat) + (random@map /.int random.int) + (random@map /.rev random.rev) + (random@map /.frac random.safe-frac) + (random@map /.text ..random-text) + (random@map /.identifier ..random-name) + (random@map /.tag ..random-name) + (random@map /.form (..random-sequence random)) + (random@map /.tuple (..random-sequence random)) + (random@map /.record (..random-record random)) + )))) + +(def: (read source-code) + (-> Text (Try Code)) + (let [parse (syntax.parse "" + syntax.no-aliases + (text.size source-code)) + start (: Source + [.dummy-cursor 0 source-code])] + (case (parse start) + (#.Left [end error]) + (#try.Failure error) + + (#.Right [end lux-code]) + (#try.Success lux-code)))) + +(def: (replace-simulation [original substitute]) + (-> [Code Code] (Random [Code Code])) + (random.rec + (function (_ replace-simulation) + (let [for-sequence (: (-> (-> (List Code) Code) (Random [Code Code])) + (function (_ to-code) + (do {@ random.monad} + [parts (..random-sequence replace-simulation)] + (wrap [(to-code (list@map product.left parts)) + (to-code (list@map product.right parts))]))))] + ($_ random.either + (random@wrap [original substitute]) + (do {@ random.monad} + [sample (random.filter (|>> (:: /.equivalence = original) not) + ($_ random.either + (random@map /.bit random.bit) + (random@map /.nat random.nat) + (random@map /.int random.int) + (random@map /.rev random.rev) + (random@map /.frac random.safe-frac) + (random@map /.text ..random-text) + (random@map /.identifier ..random-name) + (random@map /.tag ..random-name)))] + (wrap [sample sample])) + (for-sequence /.form) + (for-sequence /.tuple) + (do {@ random.monad} + [parts (..random-sequence replace-simulation)] + (wrap [(/.record (let [parts' (list@map product.left parts)] + (list.zip2 parts' parts'))) + (/.record (let [parts' (list@map product.right parts)] + (list.zip2 parts' parts')))])) + ))))) + (def: #export test Test - (<| (_.context (%.name (name-of /._))) - (do {@ r.monad} - [bit r.bit - nat r.nat - int r.int - rev r.rev - above (:: @ map (i.% +100) r.int) - below (:: @ map (i.% +100) r.int) - #let [frac (|> below - (i./ +100) - i.frac - (f.+ (i.frac above)) - (f.* -1.0))] - text (r.ascii 10) - short (r.ascii/alpha 10) - module (r.ascii/alpha 10) - #let [name [module short]]] - (`` ($_ _.and - (~~ (template [ ] - [(let [code ] - (_.test (format "Can produce " " code node.") - (and (text@= (/.to-text code)) - (:: /.equivalence = code code))))] - - ["bit" (/.bit bit) (%.bit bit)] - ["nat" (/.nat nat) (%.nat nat)] - ["int" (/.int int) (%.int int)] - ["rev" (/.rev rev) (%.rev rev)] - ["frac" (/.frac frac) (%.frac frac)] - ["text" (/.text text) (%.text text)] - ["local-ltag" (/.local-tag short) (format "#" short)] - ["lag" (/.tag [module short]) (format "#" (%.name name))] - ["local-identifier" (/.local-identifier short) short] - ["identifier" (/.identifier [module short]) (%.name name)] - ["form" (/.form (list (/.bit bit) (/.int int))) (format "(" (%.bit bit) " " (%.int int) ")")] - ["tuple" (/.tuple (list (/.bit bit) (/.int int))) (format "[" (%.bit bit) " " (%.int int) "]")] - ["record" (/.record (list [(/.bit bit) (/.int int)])) (format "{" (%.bit bit) " " (%.int int) "}")] - ))))))) + (<| (_.covering /._) + ($_ _.and + (_.with-cover [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + (_.with-cover [/.to-text] + (`` ($_ _.and + (~~ (template [ ] + [(do {@ random.monad} + [value ] + (_.cover [] + (and (case (..read (/.to-text ( value))) + (#try.Success lux-code) + (:: /.equivalence = + lux-code + ( value)) + + (#try.Failure error) + false) + (:: /.equivalence = + [.dummy-cursor ( value)] + ( value)))))] + + [/.bit random.bit #.Bit] + [/.nat random.nat #.Nat] + [/.int random.int #.Int] + [/.rev random.rev #.Rev] + [/.frac random.safe-frac #.Frac] + [/.text ..random-text #.Text] + [/.tag ..random-name #.Tag] + [/.identifier ..random-name #.Identifier] + [/.form (..random-sequence ..random) #.Form] + [/.tuple (..random-sequence ..random) #.Tuple] + [/.record (..random-record ..random) #.Record] + )) + (~~ (template [ ] + [(do {@ random.monad} + [value ] + (_.cover [] + (and (case (..read (/.to-text ( value))) + (#try.Success lux-code) + (:: /.equivalence = + lux-code + ( value)) + + (#try.Failure error) + false) + (:: /.equivalence = + [.dummy-cursor ( ["" value])] + ( value))) + ))] + + [/.local-tag ..random-text #.Tag] + [/.local-identifier ..random-text #.Identifier] + ))))) + (do {@ random.monad} + [[original substitute] (random.and ..random ..random) + [sample expected] (..replace-simulation [original substitute])] + (_.cover [/.replace] + (:: /.equivalence = + expected + (/.replace original substitute sample)))) + ))) diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index 437621fb4..4a5672382 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -319,8 +319,8 @@ @.jvm ("jvm object cast" - ( ("jvm object cast" subject) - ("jvm object cast" parameter)))}))))] + ( ("jvm object cast" parameter) + ("jvm object cast" subject)))}))))] [int/2 java/lang/Integer] [long/2 java/lang/Long] @@ -328,7 +328,7 @@ [double/2 java/lang/Double] ) -(template: (long+int/2 ) +(template: (int+long/2 ) (: (-> java/lang/Integer java/lang/Long java/lang/Long) (function (_ parameter subject) (for {@.old @@ -336,8 +336,8 @@ @.jvm ("jvm object cast" - ( ("jvm object cast" subject) - ("jvm object cast" parameter)))})))) + ( ("jvm object cast" parameter) + ("jvm object cast" subject)))})))) (def: int Test @@ -487,9 +487,9 @@ (_.lift "LAND" (binary (long/2 "jvm land" "jvm long and") /.land)) (_.lift "LOR" (binary (long/2 "jvm lor" "jvm long or") /.lor)) (_.lift "LXOR" (binary (long/2 "jvm lxor" "jvm long xor") /.lxor)) - (_.lift "LSHL" (shift (long+int/2 "jvm lshl" "jvm long shl") /.lshl)) - (_.lift "LSHR" (shift (long+int/2 "jvm lshr" "jvm long shr") /.lshr)) - (_.lift "LUSHR" (shift (long+int/2 "jvm lushr" "jvm long ushr") /.lushr))) + (_.lift "LSHL" (shift (int+long/2 "jvm lshl" "jvm long shl") /.lshl)) + (_.lift "LSHR" (shift (int+long/2 "jvm lshr" "jvm long shr") /.lshr)) + (_.lift "LUSHR" (shift (int+long/2 "jvm lushr" "jvm long ushr") /.lushr))) comparison (_.lift "LCMP" (do random.monad [reference ..$Long::random @@ -600,19 +600,16 @@ _ instruction _ /.i2l] ..$Long::wrap))))) + comparison-standard (: (-> java/lang/Float java/lang/Float Bit) + (function (_ reference subject) + (for {@.old + ("jvm fgt" subject reference) + + @.jvm + ("jvm float <" ("jvm object cast" subject) ("jvm object cast" reference))}))) comparison ($_ _.and - (_.lift "FCMPL" (comparison /.fcmpl (function (_ reference subject) - (for {@.old - ("jvm fgt" subject reference) - - @.jvm - ("jvm float <" ("jvm object cast" reference) ("jvm object cast" subject))})))) - (_.lift "FCMPG" (comparison /.fcmpg (function (_ reference subject) - (for {@.old - ("jvm fgt" subject reference) - - @.jvm - ("jvm float <" ("jvm object cast" subject) ("jvm object cast" reference))})))))] + (_.lift "FCMPL" (comparison /.fcmpl comparison-standard)) + (_.lift "FCMPG" (comparison /.fcmpg comparison-standard)))] ($_ _.and (<| (_.context "literal") literal) -- cgit v1.2.3