From fd3152f29c8d8e9cc134423da18fb828ba20ebcc Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 2 Nov 2020 20:54:09 -0400
Subject: Added CoMonad for CoFree.

---
 stdlib/source/lux/abstract/comonad.lux             |   4 -
 stdlib/source/lux/abstract/comonad/cofree.lux      |  27 +++++
 .../lux/data/collection/dictionary/plist.lux       |  41 +++++--
 stdlib/source/program/aedifex.lux                  |   5 +
 stdlib/source/program/aedifex/cli.lux              |   4 +
 stdlib/source/program/aedifex/command/clean.lux    |  47 ++++++++
 stdlib/source/test/aedifex.lux                     |   2 +
 stdlib/source/test/aedifex/cli.lux                 |   3 +
 stdlib/source/test/aedifex/command/clean.lux       | 118 +++++++++++++++++++++
 stdlib/source/test/lux/abstract.lux                |  16 ++-
 stdlib/source/test/lux/abstract/comonad/cofree.lux |  51 +++++++++
 stdlib/source/test/lux/control/parser/code.lux     |   2 +-
 stdlib/source/test/lux/data/collection.lux         |   4 +-
 .../test/lux/data/collection/dictionary/plist.lux  |  91 ++++++++++++++++
 14 files changed, 395 insertions(+), 20 deletions(-)
 create mode 100644 stdlib/source/lux/abstract/comonad/cofree.lux
 create mode 100644 stdlib/source/program/aedifex/command/clean.lux
 create mode 100644 stdlib/source/test/aedifex/command/clean.lux
 create mode 100644 stdlib/source/test/lux/abstract/comonad/cofree.lux
 create mode 100644 stdlib/source/test/lux/data/collection/dictionary/plist.lux

(limited to 'stdlib/source')

diff --git a/stdlib/source/lux/abstract/comonad.lux b/stdlib/source/lux/abstract/comonad.lux
index 0722d7a1b..94b3d06c8 100644
--- a/stdlib/source/lux/abstract/comonad.lux
+++ b/stdlib/source/lux/abstract/comonad.lux
@@ -22,10 +22,6 @@
        (-> (w a) (w (w a))))
      split))
 
-(type: #export (CoFree F a)
-  {#.doc "The CoFree CoMonad."}
-  [a (F (CoFree F a))])
-
 (macro: #export (be tokens state)
   {#.doc (doc "A co-monadic parallel to the 'do' macro."
               (let [square (function (_ n) (* n n))]
diff --git a/stdlib/source/lux/abstract/comonad/cofree.lux b/stdlib/source/lux/abstract/comonad/cofree.lux
new file mode 100644
index 000000000..eadfa788f
--- /dev/null
+++ b/stdlib/source/lux/abstract/comonad/cofree.lux
@@ -0,0 +1,27 @@
+(.module:
+  [lux #*]
+  [// (#+ CoMonad)
+   [//
+    [functor (#+ Functor)]]])
+
+(type: #export (CoFree F a)
+  {#.doc "The CoFree CoMonad."}
+  [a (F (CoFree F a))])
+
+(structure: #export (functor dsl)
+  (All [F] (-> (Functor F) (Functor (CoFree F))))
+  
+  (def: (map f [head tail])
+    [(f head) (:: dsl map (map f) tail)]))
+
+(structure: #export (comonad dsl)
+  (All [F] (-> (Functor F) (CoMonad (CoFree F))))
+
+  (def: &functor (..functor dsl))
+
+  (def: (unwrap [head tail])
+    head)
+
+  (def: (split [head tail])
+    [[head tail]
+     (:: dsl map split tail)]))
diff --git a/stdlib/source/lux/data/collection/dictionary/plist.lux b/stdlib/source/lux/data/collection/dictionary/plist.lux
index 2e08d72f2..ae62ee303 100644
--- a/stdlib/source/lux/data/collection/dictionary/plist.lux
+++ b/stdlib/source/lux/data/collection/dictionary/plist.lux
@@ -1,14 +1,30 @@
 (.module:
   [lux #*
+   [abstract
+    ["." equivalence (#+ Equivalence)]]
    [data
     ["." product]
-    ["." text ("#;." equivalence)]
+    ["." text ("#@." equivalence)]
     [collection
-     ["." list ("#;." functor)]]]])
+     ["." list ("#@." functor)]]
+    [number
+     ["n" nat]]]])
 
 (type: #export (PList a)
   (List [Text a]))
 
+(def: #export empty
+  PList
+  #.Nil)
+
+(def: #export size
+  (All [a] (-> (PList a) Nat))
+  list.size)
+
+(def: #export empty?
+  (All [a] (-> (PList a) Bit))
+  (|>> ..size (n.= 0)))
+
 (def: #export (get key properties)
   (All [a] (-> Text (PList a) (Maybe a)))
   (case properties
@@ -16,14 +32,14 @@
     #.None
 
     (#.Cons [k' v'] properties')
-    (if (text;= key k')
+    (if (text@= key k')
       (#.Some v')
       (get key properties'))))
 
 (template [<name> <type> <access>]
   [(def: #export <name>
      (All [a] (-> (PList a) (List <type>)))
-     (list;map <access>))]
+     (list@map <access>))]
 
   [keys   Text product.left]
   [values a    product.right]
@@ -31,12 +47,12 @@
 
 (def: #export (contains? key properties)
   (All [a] (-> Text (PList a) Bit))
-  (case (get key properties)
+  (case (..get key properties)
     (#.Some _)
-    #1
+    true
 
     #.None
-    #0))
+    false))
 
 (def: #export (put key val properties)
   (All [a] (-> Text a (PList a) (PList a)))
@@ -45,7 +61,7 @@
     (list [key val])
 
     (#.Cons [k' v'] properties')
-    (if (text;= key k')
+    (if (text@= key k')
       (#.Cons [key val]
               properties')
       (#.Cons [k' v']
@@ -58,7 +74,7 @@
     #.Nil
 
     (#.Cons [k' v'] properties')
-    (if (text;= key k')
+    (if (text@= key k')
       (#.Cons [k' (f v')] properties')
       (#.Cons [k' v'] (update key f properties')))))
 
@@ -69,7 +85,12 @@
     properties
 
     (#.Cons [k' v'] properties')
-    (if (text;= key k')
+    (if (text@= key k')
       properties'
       (#.Cons [k' v']
               (remove key properties')))))
+
+(def: #export equivalence
+  (All [a] (-> (Equivalence a) (Equivalence (PList a))))
+  (|>> (equivalence.product text.equivalence)
+       list.equivalence))
diff --git a/stdlib/source/program/aedifex.lux b/stdlib/source/program/aedifex.lux
index a3712a19f..d4c9036f3 100644
--- a/stdlib/source/program/aedifex.lux
+++ b/stdlib/source/program/aedifex.lux
@@ -41,6 +41,7 @@
    ["#." dependency #_
     ["#" resolution]]
    ["#." command
+    ["#/." clean]
     ["#/." pom]
     ["#/." install]
     ["#/." build]
@@ -75,6 +76,10 @@
     (case ?profile
       (#try.Success profile)
       (case operation
+        #/cli.Clean
+        (exec (/command/clean.do! (file.async file.default) profile)
+          (wrap []))
+
         #/cli.POM
         (exec (/command/pom.do! (file.async file.default) profile)
           (wrap []))
diff --git a/stdlib/source/program/aedifex/cli.lux b/stdlib/source/program/aedifex/cli.lux
index 666e5a701..9d73f9181 100644
--- a/stdlib/source/program/aedifex/cli.lux
+++ b/stdlib/source/program/aedifex/cli.lux
@@ -32,6 +32,7 @@
          (cli.this "test")))
 
 (type: #export Command
+  #Clean
   #POM
   #Dependencies
   #Install
@@ -42,6 +43,8 @@
 (def: #export equivalence
   (Equivalence Command)
   ($_ equivalence.sum
+      ## #Clean
+      ..any-equivalence
       ## #POM
       ..any-equivalence
       ## #Dependencies
@@ -61,6 +64,7 @@
 (def: command'
   (Parser Command)
   ($_ <>.or
+      (cli.this "clean")
       (cli.this "pom")
       (cli.this "deps")
       (cli.this "install")
diff --git a/stdlib/source/program/aedifex/command/clean.lux b/stdlib/source/program/aedifex/command/clean.lux
new file mode 100644
index 000000000..f4f5e1f9e
--- /dev/null
+++ b/stdlib/source/program/aedifex/command/clean.lux
@@ -0,0 +1,47 @@
+(.module:
+  [lux #*
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." try (#+ Try)]
+    [security
+     ["!" capability]]
+    [concurrency
+     ["." promise (#+ Promise)]]]
+   [world
+    ["." file (#+ Path File Directory)]]]
+  ["." /// #_
+   [command (#+ Command)]
+   ["#" profile]
+   ["#." action (#+ Action)]])
+
+(def: (clean-files! root)
+  (-> (Directory Promise) (Promise (Try Any)))
+  (do {! ///action.monad}
+    [nodes (: (Promise (Try (List (File Promise))))
+              (!.use (:: root files) []))
+     _ (monad.map ! (function (_ node)
+                      (!.use (:: node delete) []))
+                  nodes)]
+    (wrap [])))
+
+(def: #export (do! fs profile)
+  (-> (file.System Promise) (Command Any))
+  (case (get@ #///.target profile)
+    (#.Some target)
+    (do {! ///action.monad}
+      [target (: (Promise (Try (Directory Promise)))
+                 (!.use (:: fs directory) target))
+       _ (loop [root target]
+           (do !
+             [_ (..clean-files! root)
+              subs (: (Promise (Try (List (Directory Promise))))
+                      (!.use (:: root directories) []))
+              _ (monad.map ! recur subs)]
+             (!.use (:: root discard) [])))]
+      (exec (log! "No 'target' defined for clean-up.")
+        (wrap [])))
+    
+    #.None
+    (exec (log! "No 'target' defined for clean-up.")
+      (:: ///action.monad wrap []))))
diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux
index ed32b969c..a4fd15bec 100644
--- a/stdlib/source/test/aedifex.lux
+++ b/stdlib/source/test/aedifex.lux
@@ -9,6 +9,7 @@
    ["#." artifact]
    ["#." input]
    ["#." command #_
+    ["#/." clean]
     ["#/." pom]
     ["#/." install]]
    ["#." local]
@@ -27,6 +28,7 @@
   ($_ _.and
       /artifact.test
       /input.test
+      /command/clean.test
       /command/pom.test
       /command/install.test
       /local.test
diff --git a/stdlib/source/test/aedifex/cli.lux b/stdlib/source/test/aedifex/cli.lux
index dfbf0b7a9..0dde0402a 100644
--- a/stdlib/source/test/aedifex/cli.lux
+++ b/stdlib/source/test/aedifex/cli.lux
@@ -29,6 +29,8 @@
 (def: command
   (Random /.Command)
   ($_ random.or
+      ## #Clean
+      (random@wrap [])
       ## #POM
       (random@wrap [])
       ## #Dependencies
@@ -54,6 +56,7 @@
 (def: (format value)
   (-> /.Command (List Text))
   (case value
+    #/.Clean (list "clean")
     #/.POM (list "pom")
     #/.Dependencies (list "deps")
     #/.Install (list "install")
diff --git a/stdlib/source/test/aedifex/command/clean.lux b/stdlib/source/test/aedifex/command/clean.lux
new file mode 100644
index 000000000..73207fa14
--- /dev/null
+++ b/stdlib/source/test/aedifex/command/clean.lux
@@ -0,0 +1,118 @@
+(.module:
+  [lux #*
+   ["_" test (#+ Test)]
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." try (#+ Try)]
+    [concurrency
+     ["." promise (#+ Promise)]]
+    [security
+     ["!" capability]]]
+   [data
+    [binary (#+ Binary)]
+    ["." product]
+    ["." text
+     ["%" format (#+ format)]]
+    [number
+     ["n" nat]]
+    [collection
+     ["." list ("#@." functor)]
+     ["." set]]]
+   [math
+    ["." random (#+ Random)]]
+   [world
+    ["." file (#+ Path File)]]]
+  [///
+   ["@." profile]
+   [//
+    [lux
+     [data
+      ["_." binary]]]]]
+  {#program
+   ["." /
+    ["//#" /// #_
+     ["#" profile]
+     ["#." action (#+ Action)]]]})
+
+(def: node-name
+  (Random Text)
+  (random.ascii/alpha 10))
+
+(def: (files prefix)
+  (-> Path (Random (List [Path Binary])))
+  (do {! random.monad}
+    [count (:: ! map (n.% 10) random.nat)
+     names (random.set text.hash count ..node-name)
+     contents (random.list count (_binary.random 100))]
+    (wrap (list.zip/2 (list@map (|>> (format prefix)) (set.to-list names))
+                      contents))))
+
+(def: (create-file! fs [path content])
+  (-> (file.System Promise) [Path Binary] (Promise (Try Any)))
+  (do {! (try.with promise.monad)}
+    [file (: (Promise (Try (File Promise)))
+             (file.get-file promise.monad fs path))]
+    (!.use (:: file over-write) content)))
+
+(def: (create-directory! fs path files)
+  (-> (file.System Promise) Path (List [Path Binary]) (Promise (Try Any)))
+  (do {! (try.with promise.monad)}
+    [_ (: (Promise (Try Path))
+          (file.make-directories promise.monad fs path))
+     _ (monad.map ! (..create-file! fs) files)]
+    (wrap [])))
+
+(def: (directory-exists? fs)
+  (-> (file.System Promise) Path (Promise (Try Bit)))
+  (|>> (file.directory-exists? promise.monad fs) (try.lift promise.monad)))
+
+(def: (file-exists? fs)
+  (-> (file.System Promise) Path (Promise (Try Bit)))
+  (|>> (file.file-exists? promise.monad fs) (try.lift promise.monad)))
+
+(def: (assets-exist? fs directory-path files)
+  (-> (file.System Promise) Path (List [Path Binary]) (Promise (Try Bit)))
+  (do {! (try.with promise.monad)}
+    [directory-exists? (..directory-exists? fs directory-path)
+     files-exist? (: (Action (List Bit))
+                     (|> files
+                         (list@map product.left)
+                         (monad.map ///action.monad (..file-exists? fs))))]
+    (wrap (and directory-exists?
+               (list.every? (|>>) files-exist?)))))
+
+(def: #export test
+  Test
+  (<| (_.covering /._)
+      (do {! random.monad}
+        [context ..node-name
+         target ..node-name
+         sub ..node-name
+         #let [fs (file.mock (:: file.default separator))
+               / (:: fs separator)
+               target-path (format context / target)
+               sub-path (format target-path / sub)]
+         direct-files (..files (format target-path /))
+         sub-files (..files (format sub-path /))
+
+         dummy @profile.random]
+        (wrap (do promise.monad
+                [verdict (do {! (try.with promise.monad)}
+                           [_ (..create-directory! fs target-path direct-files)
+                            _ (..create-directory! fs sub-path sub-files)
+                            context-exists!/pre (..directory-exists? fs context)
+                            target-exists!/pre (..assets-exist? fs target-path direct-files)
+                            sub-exists!/pre (..assets-exist? fs sub-path sub-files)
+                            _ (/.do! fs (set@ #///.target (#.Some target-path) dummy))
+                            context-exists!/post (..directory-exists? fs context)
+                            target-exists!/post (..assets-exist? fs target-path direct-files)
+                            sub-exists!/post (..assets-exist? fs sub-path sub-files)]
+                           (wrap (and (and context-exists!/pre
+                                           context-exists!/post)
+                                      (and target-exists!/pre
+                                           (not target-exists!/post))
+                                      (and sub-exists!/pre
+                                           (not sub-exists!/post)))))]
+                (_.claim [/.do!]
+                         (try.default false verdict)))))))
diff --git a/stdlib/source/test/lux/abstract.lux b/stdlib/source/test/lux/abstract.lux
index d99d3c063..9fd3986b8 100644
--- a/stdlib/source/test/lux/abstract.lux
+++ b/stdlib/source/test/lux/abstract.lux
@@ -4,7 +4,8 @@
   ["." / #_
    ["#." apply]
    ["#." codec]
-   ["#." comonad]
+   ["#." comonad
+    ["#/." cofree]]
    ["#." enum]
    ["#." equivalence]
    ["#." fold]
@@ -31,19 +32,26 @@
       /monad/free.test
       ))
 
+(def: comonad
+  Test
+  ($_ _.and
+      /comonad.test
+      /comonad/cofree.test
+      ))
+
 (def: #export test
   Test
   ($_ _.and
       /apply.test
       /codec.test
-      /comonad.test
       /enum.test
       /equivalence.test
       /fold.test
-      ..functor
       /interval.test
-      ..monad
       /monoid.test
       /order.test
       /predicate.test
+      ..functor
+      ..monad
+      ..comonad
       ))
diff --git a/stdlib/source/test/lux/abstract/comonad/cofree.lux b/stdlib/source/test/lux/abstract/comonad/cofree.lux
new file mode 100644
index 000000000..6cf767e65
--- /dev/null
+++ b/stdlib/source/test/lux/abstract/comonad/cofree.lux
@@ -0,0 +1,51 @@
+(.module:
+  [lux #*
+   ["_" test (#+ Test)]
+   [abstract
+    [functor (#+ Functor)]
+    [comonad (#+ CoMonad)]
+    {[0 #spec]
+     [/
+      ["$." functor (#+ Injection Comparison)]
+      ["$." comonad]]}]
+   [control
+    ["//" continuation]]
+   [data
+    [collection
+     ["." list]
+     ["." sequence (#+ Sequence) ("#@." comonad)]]]
+   [math
+    ["." random]]]
+  {1
+   ["." /]})
+
+(def: (injection value)
+  (Injection (/.CoFree Sequence))
+  [value (sequence@map injection (sequence.repeat value))])
+
+(def: (interpret [head tail])
+  (All [a] (-> (/.CoFree Sequence a) (Sequence a)))
+  (|> tail
+      (sequence@map (:: (/.comonad sequence.functor) unwrap))
+      [head]
+      //.pending))
+
+(def: comparison
+  (Comparison (/.CoFree Sequence))
+  (function (_ == left right)
+    (:: (list.equivalence ==) =
+        (sequence.take 100 (..interpret left))
+        (sequence.take 100 (..interpret right)))))
+
+(def: #export test
+  Test
+  (<| (_.covering /._)
+      (_.with-cover [/.CoFree])
+      ($_ _.and
+          (_.with-cover [/.functor]
+            ($functor.spec ..injection ..comparison (: (Functor (/.CoFree Sequence))
+                                                       (/.functor sequence.functor))))
+          (_.with-cover [/.comonad]
+            ($comonad.spec ..injection ..comparison (: (CoMonad (/.CoFree Sequence))
+                                                       (/.comonad sequence.functor))))
+          )))
diff --git a/stdlib/source/test/lux/control/parser/code.lux b/stdlib/source/test/lux/control/parser/code.lux
index de2601c45..a4f25df4d 100644
--- a/stdlib/source/test/lux/control/parser/code.lux
+++ b/stdlib/source/test/lux/control/parser/code.lux
@@ -71,7 +71,7 @@
                     [/.nat /.nat! random.nat code.nat nat.equivalence]
                     [/.int /.int! random.int code.int int.equivalence]
                     [/.rev /.rev! random.rev code.rev rev.equivalence]
-                    [/.frac /.frac! random.frac code.frac frac.equivalence]
+                    [/.frac /.frac! random.safe-frac code.frac frac.equivalence]
                     [/.text /.text! (random.unicode 1) code.text text.equivalence]
                     [/.identifier /.identifier! ..random-name code.identifier name.equivalence]
                     [/.tag /.tag! ..random-name code.tag name.equivalence]
diff --git a/stdlib/source/test/lux/data/collection.lux b/stdlib/source/test/lux/data/collection.lux
index 0d6cb1e64..82643dfde 100644
--- a/stdlib/source/test/lux/data/collection.lux
+++ b/stdlib/source/test/lux/data/collection.lux
@@ -9,7 +9,8 @@
    ["#." sequence]
    ["#." stack]
    ["#." dictionary
-    ["#/." ordered]]
+    ["#/." ordered]
+    ["#/." plist]]
    ["#." queue
     ["#/." priority]]
    ["#." set
@@ -22,6 +23,7 @@
   ($_ _.and
       /dictionary.test
       /dictionary/ordered.test
+      /dictionary/plist.test
       ))
 
 (def: queue
diff --git a/stdlib/source/test/lux/data/collection/dictionary/plist.lux b/stdlib/source/test/lux/data/collection/dictionary/plist.lux
new file mode 100644
index 000000000..cac27e0cf
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/dictionary/plist.lux
@@ -0,0 +1,91 @@
+(.module:
+  [lux #*
+   ["_" test (#+ Test)]
+   [abstract
+    [monad (#+ do)]
+    {[0 #spec]
+     [/
+      ["$." equivalence]]}]
+   [data
+    ["." bit ("#@." equivalence)]
+    ["." maybe ("#@." monad)]
+    ["." text]
+    [number
+     ["n" nat]]
+    [collection
+     ["." set]
+     ["." list]]]
+   [math
+    ["." random (#+ Random)]]]
+  {1
+   ["." /]})
+
+(def: #export (random size gen-key gen-value)
+  (All [v]
+    (-> Nat (Random Text) (Random v) (Random (/.PList v))))
+  (do random.monad
+    [keys (random.set text.hash size gen-key)
+     values (random.list size gen-value)]
+    (wrap (list.zip/2 (set.to-list keys) values))))
+
+(def: #export test
+  Test
+  (<| (_.covering /._)
+      (_.with-cover [/.PList])
+      (do {! random.monad}
+        [#let [gen-key (random.ascii/alpha 10)]
+         size (:: ! map (n.% 100) random.nat)
+         sample (..random size gen-key random.nat)
+
+         #let [keys (|> sample /.keys (set.from-list text.hash))]
+         extra-key (random.filter (|>> (set.member? keys) not)
+                                  gen-key)
+         extra-value random.nat
+         shift random.nat]
+        ($_ _.and
+            (_.with-cover [/.equivalence]
+              ($equivalence.spec (/.equivalence n.equivalence)
+                                 (..random size gen-key random.nat)))
+            
+            (_.cover [/.size]
+                     (n.= size (/.size sample)))
+            (_.cover [/.empty?]
+                     (bit@= (n.= 0 (/.size sample))
+                            (/.empty? sample)))
+            (_.cover [/.empty]
+                     (/.empty? /.empty))
+            (_.cover [/.keys /.values]
+                     (:: (/.equivalence n.equivalence) =
+                         sample
+                         (list.zip/2 (/.keys sample)
+                                     (/.values sample))))
+            (_.cover [/.contains?]
+                     (and (list.every? (function (_ key)
+                                         (/.contains? key sample))
+                                       (/.keys sample))
+                          (not (/.contains? extra-key sample))))
+            (_.cover [/.put]
+                     (let [sample+ (/.put extra-key extra-value sample)]
+                       (and (not (/.contains? extra-key sample))
+                            (/.contains? extra-key sample+)
+                            (n.= (inc (/.size sample))
+                                 (/.size sample+)))))
+            (_.cover [/.get]
+                     (|> sample
+                         (/.put extra-key extra-value)
+                         (/.get extra-key)
+                         (maybe@map (n.= extra-value))
+                         (maybe.default false)))
+            (_.cover [/.update]
+                     (|> sample
+                         (/.put extra-key extra-value)
+                         (/.update extra-key (n.+ shift))
+                         (/.get extra-key)
+                         (maybe@map (n.= (n.+ shift extra-value)))
+                         (maybe.default false)))
+            (_.cover [/.remove]
+                     (|> sample
+                         (/.put extra-key extra-value)
+                         (/.remove extra-key)
+                         (:: (/.equivalence n.equivalence) = sample)))
+            ))))
-- 
cgit v1.2.3