Pure-Lux implementation for biggest and smallest Frac values.

6 files changed, 271 insertions, 5 deletions

diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux
index c9994aafa..e3a2717cd 100644
--- a/stdlib/source/test/aedifex.lux
+++ b/stdlib/source/test/aedifex.lux
@@ -11,7 +11,8 @@
    ["#." command #_
     ["#/." clean]
     ["#/." pom]
-    ["#/." install]]
+    ["#/." install]
+    ["#/." deploy]]
    ["#." local]
    ["#." cache]
    ["#." dependency]
@@ -32,6 +33,7 @@
       /command/clean.test
       /command/pom.test
       /command/install.test
+      /command/deploy.test
       /local.test
       /cache.test
       /dependency.test
diff --git a/stdlib/source/test/aedifex/cli.lux b/stdlib/source/test/aedifex/cli.lux
index 1edfb381f..b7be4e8bf 100644
--- a/stdlib/source/test/aedifex/cli.lux
+++ b/stdlib/source/test/aedifex/cli.lux
@@ -60,7 +60,7 @@
     #/.POM (list "pom")
     #/.Dependencies (list "deps")
     #/.Install (list "install")
-    (#/.Deploy repository user password) (list "deploy" repository user password)
+    (#/.Deploy repository [user password]) (list "deploy" repository user password)
     (#/.Compilation compilation) (..format-compilation compilation)
     (#/.Auto compilation) (list& "auto" (..format-compilation compilation))))
 
diff --git a/stdlib/source/test/aedifex/command/deploy.lux b/stdlib/source/test/aedifex/command/deploy.lux
new file mode 100644
index 000000000..20718f915
--- /dev/null
+++ b/stdlib/source/test/aedifex/command/deploy.lux
@@ -0,0 +1,129 @@
+(.module:
+  [lux #*
+   ["_" test (#+ Test)]
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." try (#+ Try) ("#@." functor)]
+    ["." exception]
+    [concurrency
+     ["." promise (#+ Promise)]]
+    [security
+     ["!" capability]]]
+   [data
+    ["." maybe]
+    ["." binary]
+    ["." text ("#@." equivalence)
+     ["%" format (#+ format)]
+     ["." encoding]]
+    ["." format #_
+     ["#" binary]
+     ["." tar]
+     ["." xml]]
+    [collection
+     ["." set (#+ Set)]
+     ["." dictionary (#+ Dictionary)]]]
+   [math
+    ["." random (#+ Random)]]
+   [world
+    ["." file (#+ Path File)]]]
+  [program
+   [compositor
+    ["." export]]]
+  [///
+   ["@." profile]
+   ["@." repository]]
+  {#program
+   ["." /
+    ["//#" /// #_
+     ["#" profile]
+     ["#." action]
+     ["#." pom]
+     ["#." local]
+     ["#." hash]
+     ["#." repository (#+ Identity Repository)]
+     ["#." artifact (#+ Artifact)
+      ["#/." extension]]]]})
+
+(def: (make-sources! fs sources)
+  (-> (file.System Promise) (Set Path) (Promise (Try Any)))
+  (loop [sources (set.to-list sources)]
+    (case sources
+      #.Nil
+      (|> []
+          (:: try.monad wrap)
+          (:: promise.monad wrap))
+      
+      (#.Cons head tail)
+      (do (try.with promise.monad)
+        [_ (: (Promise (Try Path))
+              (file.make-directories promise.monad fs head))
+         _ (: (Promise (Try (File Promise)))
+              (file.get-file promise.monad fs (format head (:: fs separator) head ".lux")))]
+        (recur tail)))))
+
+(def: (execute! repository fs identity artifact profile)
+  (-> (Repository Promise) (file.System Promise)
+      Identity Artifact ///.Profile
+      (Promise (Try Any)))
+  (do ///action.monad
+    [_ (..make-sources! fs (get@ #///.sources profile))
+     _ (: (Promise (Try Path))
+          (file.make-directories promise.monad fs (///local.repository fs)))]
+    (/.do! repository fs identity artifact profile)))
+
+(def: #export test
+  Test
+  (<| (_.covering /._)
+      (do {! random.monad}
+        [[artifact expected-pom profile]
+         (random.one (function (_ profile)
+                       (do maybe.monad
+                         [artifact (get@ #///.identity profile)
+                          expected-pom (try.to-maybe (///pom.write profile))]
+                         (wrap [artifact expected-pom profile])))
+                     @profile.random)
+         
+         identity @repository.identity
+         #let [repository (///repository.mock (@repository.simulation identity)
+                                              @repository.empty)
+               fs (file.mock (:: file.default separator))]]
+        (wrap (do {! promise.monad}
+                [verdict (do {! ///action.monad}
+                           [_ (..execute! repository fs identity artifact profile)
+                            expected-library (|> profile
+                                                 (get@ #///.sources)
+                                                 set.to-list
+                                                 (export.library fs)
+                                                 (:: ! map (format.run tar.writer)))
+                            
+                            actual-pom (:: repository download artifact ///artifact/extension.pom)
+                            actual-library (:: repository download artifact ///artifact/extension.lux-library)
+                            actual-sha-1 (:: repository download artifact ///artifact/extension.sha-1)
+                            actual-md5 (:: repository download artifact ///artifact/extension.md5)
+
+                            #let [deployed-library!
+                                  (:: binary.equivalence =
+                                      expected-library
+                                      actual-library)
+
+                                  deployed-pom!
+                                  (:: binary.equivalence =
+                                      (|> expected-pom (:: xml.codec encode) encoding.to-utf8)
+                                      actual-pom)
+
+                                  deployed-sha-1!
+                                  (:: binary.equivalence =
+                                      (///hash.data (///hash.sha-1 expected-library))
+                                      actual-sha-1)
+
+                                  deployed-md5!
+                                  (:: binary.equivalence =
+                                      (///hash.data (///hash.md5 expected-library))
+                                      actual-md5)]]
+                           (wrap (and deployed-library!
+                                      deployed-pom!
+                                      deployed-sha-1!
+                                      deployed-md5!)))]
+                (_.claim [/.do!]
+                         (try.default false verdict)))))))
diff --git a/stdlib/source/test/aedifex/repository.lux b/stdlib/source/test/aedifex/repository.lux
index 4f96d9329..5f05d342e 100644
--- a/stdlib/source/test/aedifex/repository.lux
+++ b/stdlib/source/test/aedifex/repository.lux
@@ -27,7 +27,7 @@
      ["#." artifact (#+ Version Artifact)
       ["#/." extension (#+ Extension)]]]]})
 
-(def: identity
+(def: #export identity
   (Random Identity)
   (random.and (random.ascii/alpha 10)
               (random.ascii/alpha 10)))
@@ -59,11 +59,11 @@
 (type: Store
   (Dictionary [Artifact Extension] Binary))
 
-(def: empty
+(def: #export empty
   Store
   (dictionary.new ..item-hash))
 
-(structure: (simulation identity)
+(structure: #export (simulation identity)
   (-> Identity (/.Simulation Store))
 
   (def: (on-download artifact extension state)
diff --git a/stdlib/source/test/lux/data/collection.lux b/stdlib/source/test/lux/data/collection.lux
index 497123614..bcbda46b9 100644
--- a/stdlib/source/test/lux/data/collection.lux
+++ b/stdlib/source/test/lux/data/collection.lux
@@ -17,6 +17,7 @@
     ["#/." multi]
     ["#/." ordered]]
    ["#." tree
+    ["#/." finger]
     ["#/." zipper]]])
 
 (def: dictionary
@@ -46,6 +47,7 @@
   Test
   ($_ _.and
       /tree.test
+      /tree/finger.test
       /tree/zipper.test
       ))
 
diff --git a/stdlib/source/test/lux/data/collection/tree/finger.lux b/stdlib/source/test/lux/data/collection/tree/finger.lux
new file mode 100644
index 000000000..a0dfabb54
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/tree/finger.lux
@@ -0,0 +1,133 @@
+(.module:
+  [lux #*
+   ["_" test (#+ Test)]
+   [abstract
+    [monad (#+ do)]]
+   [data
+    ["." maybe ("#@." functor)]
+    ["." text ("#@." equivalence monoid)]
+    [number
+     ["n" nat]]]
+   [math
+    ["." random]]
+   [type (#+ :by-example)]]
+  {1
+   ["." /]})
+
+(def: builder
+  (/.builder text.monoid))
+
+(def: :@:
+  (:by-example [@]
+               {(/.Builder @ Text)
+                ..builder}
+               @))
+
+(def: #export test
+  Test
+  (<| (_.covering /._)
+      (_.with-cover [/.Tree])
+      (do {! random.monad}
+        [tag-left (random.ascii/alpha-num 1)
+         tag-right (random.filter (|>> (text@= tag-left) not)
+                                  (random.ascii/alpha-num 1))
+         expected-left random.nat
+         expected-right random.nat]
+        ($_ _.and
+            (_.cover [/.Builder /.builder]
+                     (exec (/.builder text.monoid)
+                       true))
+            (_.cover [/.tag]
+                     (and (text@= tag-left
+                                  (/.tag (:: ..builder leaf tag-left expected-left)))
+                          (text@= (text@compose tag-left tag-right)
+                                  (/.tag (:: ..builder branch
+                                             (:: ..builder leaf tag-left expected-left)
+                                             (:: ..builder leaf tag-right expected-right))))))
+            (_.cover [/.root]
+                     (and (case (/.root (:: ..builder leaf tag-left expected-left))
+                            (#.Left actual)
+                            (n.= expected-left actual)
+                            
+                            (#.Right _)
+                            false)
+                          (case (/.root (:: ..builder branch
+                                            (:: ..builder leaf tag-left expected-left)
+                                            (:: ..builder leaf tag-right expected-right)))
+                            (#.Left _)
+                            false
+                            
+                            (#.Right [left right])
+                            (case [(/.root left)
+                                   (/.root right)]
+                              [(#.Left actual-left) (#.Left actual-right)]
+                              (and (n.= expected-left actual-left)
+                                   (n.= expected-right actual-right))
+                              
+                              _
+                              false))))
+            (_.cover [/.value]
+                     (and (n.= expected-left
+                               (/.value (:: ..builder leaf tag-left expected-left)))
+                          (n.= expected-left
+                               (/.value (:: ..builder branch
+                                            (:: ..builder leaf tag-left expected-left)
+                                            (:: ..builder leaf tag-right expected-right))))))
+            (_.cover [/.search]
+                     (let [can-find-correct-one!
+                           (|> (:: ..builder leaf tag-left expected-left)
+                               (/.search (text.contains? tag-left))
+                               (maybe@map (n.= expected-left))
+                               (maybe.default false))
+
+                           cannot-find-incorrect-one!
+                           (|> (:: ..builder leaf tag-right expected-right)
+                               (/.search (text.contains? tag-left))
+                               (maybe@map (n.= expected-left))
+                               (maybe.default false)
+                               not)
+
+                           can-find-left!
+                           (|> (:: ..builder branch
+                                   (:: ..builder leaf tag-left expected-left)
+                                   (:: ..builder leaf tag-right expected-right))
+                               (/.search (text.contains? tag-left))
+                               (maybe@map (n.= expected-left))
+                               (maybe.default false))
+
+                           can-find-right!
+                           (|> (:: ..builder branch
+                                   (:: ..builder leaf tag-left expected-left)
+                                   (:: ..builder leaf tag-right expected-right))
+                               (/.search (text.contains? tag-right))
+                               (maybe@map (n.= expected-right))
+                               (maybe.default false))]
+                       (and can-find-correct-one!
+                            cannot-find-incorrect-one!
+                            can-find-left!
+                            can-find-right!)))
+            (_.cover [/.found?]
+                     (let [can-find-correct-one!
+                           (/.found? (text.contains? tag-left)
+                                     (:: ..builder leaf tag-left expected-left))
+
+                           cannot-find-incorrect-one!
+                           (not (/.found? (text.contains? tag-left)
+                                          (:: ..builder leaf tag-right expected-right)))
+
+                           can-find-left!
+                           (/.found? (text.contains? tag-left)
+                                     (:: ..builder branch
+                                         (:: ..builder leaf tag-left expected-left)
+                                         (:: ..builder leaf tag-right expected-right)))
+
+                           can-find-right!
+                           (/.found? (text.contains? tag-right)
+                                     (:: ..builder branch
+                                         (:: ..builder leaf tag-left expected-left)
+                                         (:: ..builder leaf tag-right expected-right)))]
+                       (and can-find-correct-one!
+                            cannot-find-incorrect-one!
+                            can-find-left!
+                            can-find-right!)))
+            ))))