Calculate SHA-1 and MD5 hashes.

10 files changed, 229 insertions, 80 deletions

diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
index 5796cc8b9..f0de62d52 100644
--- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
@@ -169,10 +169,10 @@
           )))
 
 (template [<name> <op>]
-  [(def: (<name> [xI yI])
+  [(def: (<name> [parameterI subject1])
      (Binary Inst)
-     (|>> xI
-          yI
+     (|>> subject1
+          parameterI
           <op>))]
 
   [int::+ _.IADD]
@@ -217,12 +217,12 @@
 (def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean))
 
 (template [<name> <op>]
-  [(def: (<name> [xI yI])
+  [(def: (<name> [referenceI subjectI])
      (Binary Inst)
      (<| _.with-label (function (_ @then))
          _.with-label (function (_ @end))
-         (|>> xI
-              yI
+         (|>> subjectI
+              referenceI
               (<op> @then)
               falseI
               (_.GOTO @end)
@@ -238,12 +238,12 @@
   )
 
 (template [<name> <op> <reference>]
-  [(def: (<name> [xI yI])
+  [(def: (<name> [referenceI subjectI])
      (Binary Inst)
      (<| _.with-label (function (_ @then))
          _.with-label (function (_ @end))
-         (|>> xI
-              yI
+         (|>> subjectI
+              referenceI
               <op>
               (_.int <reference>)
               (_.IF_ICMPEQ @then)
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 <type> <type> <type>))
              (///bundle.install "or" (//lux.binary <type> <type> <type>))
              (///bundle.install "xor" (//lux.binary <type> <type> <type>))
-             (///bundle.install "shl" (//lux.binary <type> ..int <type>))
-             (///bundle.install "shr" (//lux.binary <type> ..int <type>))
-             (///bundle.install "ushr" (//lux.binary <type> ..int <type>))
+             (///bundle.install "shl" (//lux.binary ..int <type> <type>))
+             (///bundle.install "shr" (//lux.binary ..int <type> <type>))
+             (///bundle.install "ushr" (//lux.binary ..int <type> <type>))
              )))]
 
   [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 [<name> <algorithm>]
+  [(def: #export (<name> value)
+     (-> Binary Hash)
+     (|> (java/security/MessageDigest::getInstance [<algorithm>])
+         (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 [<desc> <code> <text>]
-                      [(let [code <code>]
-                         (_.test (format "Can produce " <desc> " code node.")
-                                 (and (text@= <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 [<coverage> <random> <tag>]
+                          [(do {@ random.monad}
+                             [value <random>]
+                             (_.cover [<coverage>]
+                                      (and (case (..read (/.to-text (<coverage> value)))
+                                             (#try.Success lux-code)
+                                             (:: /.equivalence =
+                                                 lux-code
+                                                 (<coverage> value))
+                                             
+                                             (#try.Failure error)
+                                             false)
+                                           (:: /.equivalence =
+                                               [.dummy-cursor (<tag> value)]
+                                               (<coverage> 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 [<coverage> <random> <tag>]
+                          [(do {@ random.monad}
+                             [value <random>]
+                             (_.cover [<coverage>]
+                                      (and (case (..read (/.to-text (<coverage> value)))
+                                             (#try.Success lux-code)
+                                             (:: /.equivalence =
+                                                 lux-code
+                                                 (<coverage> value))
+                                             
+                                             (#try.Failure error)
+                                             false)
+                                           (:: /.equivalence =
+                                               [.dummy-cursor (<tag> ["" value])]
+                                               (<coverage> 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"
-                 (<new-extension> ("jvm object cast" subject)
-                                  ("jvm object cast" parameter)))}))))]
+                 (<new-extension> ("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 <old-extension> <new-extension>)
+(template: (int+long/2 <old-extension> <new-extension>)
   (: (-> java/lang/Integer java/lang/Long java/lang/Long)
      (function (_ parameter subject)
        (for {@.old
@@ -336,8 +336,8 @@
              
              @.jvm
              ("jvm object cast"
-              (<new-extension> ("jvm object cast" subject)
-                               ("jvm object cast" parameter)))}))))
+              (<new-extension> ("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)