From 95100b81d87e55668b242ef40aac623f52523e03 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 3 Apr 2017 20:34:38 -0400
Subject: - Persistent queues and sequences can now be empty.

---
 stdlib/source/lux/data/coll/priority-queue.lux | 135 +++++++------
 stdlib/source/lux/data/coll/seq.lux            | 260 ++++++++++++++++---------
 2 files changed, 242 insertions(+), 153 deletions(-)

(limited to 'stdlib/source')

diff --git a/stdlib/source/lux/data/coll/priority-queue.lux b/stdlib/source/lux/data/coll/priority-queue.lux
index 9bc65df1d..f02b4de57 100644
--- a/stdlib/source/lux/data/coll/priority-queue.lux
+++ b/stdlib/source/lux/data/coll/priority-queue.lux
@@ -1,86 +1,103 @@
 (;module:
   lux
-  (lux (control eq)
+  (lux (control eq
+                monad)
        (data (coll (tree ["F" finger]))
-             [number])))
+             [number]
+             maybe)))
 
 (type: #export Priority Nat)
 
 (type: #export (Queue a)
-  (F;Fingers Priority a))
+  (Maybe (F;Fingers Priority a)))
 
 (def: max-priority Priority (_lux_proc [ "nat" "max-value"] []))
 (def: min-priority Priority (_lux_proc [ "nat" "min-value"] []))
 
-(def: #export (new priority value)
-  (All [a] (-> Priority a (Queue a)))
-  {#F;monoid number;Max@Monoid<Nat>
-   #F;tree (#F;Leaf priority value)})
+(def: #export empty
+  Queue
+  #;None)
 
 (def: #export (peek queue)
-  (All [a] (-> (Queue a) a))
-  (default (undefined)
-    (F;search (n.= (F;tag queue)) queue)))
+  (All [a] (-> (Queue a) (Maybe a)))
+  (do Monad<Maybe>
+    [fingers queue]
+    (wrap (default (undefined)
+            (F;search (n.= (F;tag fingers)) fingers)))))
 
 (def: #export (size queue)
   (All [a] (-> (Queue a) Nat))
-  (loop [node (get@ #F;tree queue)]
-    (case node
-      (#F;Leaf _ _)
-      +1
+  (case queue
+    #;None
+    +0
 
-      (#F;Branch _ left right)
-      (n.+ (recur left) (recur right)))))
+    (#;Some fingers)
+    (loop [node (get@ #F;tree fingers)]
+      (case node
+        (#F;Leaf _ _)
+        +1
+
+        (#F;Branch _ left right)
+        (n.+ (recur left) (recur right))))))
 
 (def: #export (member? Eq<a> queue member)
   (All [a] (-> (Eq a) (Queue a) a Bool))
-  (loop [node (get@ #F;tree queue)]
-    (case node
-      (#F;Leaf _ reference)
-      (:: Eq<a> = reference member)
+  (case queue
+    #;None
+    false
+
+    (#;Some fingers)
+    (loop [node (get@ #F;tree fingers)]
+      (case node
+        (#F;Leaf _ reference)
+        (:: Eq<a> = reference member)
 
-      (#F;Branch _ left right)
-      (or (recur left)
-          (recur right)))))
+        (#F;Branch _ left right)
+        (or (recur left)
+            (recur right))))))
 
 (def: #export (pop queue)
   (All [a] (-> (Queue a) (Queue a)))
-  (let [highest-priority (F;tag queue)
-        node' (loop [node (get@ #F;tree queue)]
-                (case node
-                  (#F;Leaf priority reference)
-                  (if (n.= highest-priority priority)
-                    #;None
-                    (#;Some node))
-
-                  (#F;Branch priority left right)
-                  (if (n.= highest-priority (F;tag (set@ #F;tree left queue)))
-                    (case (recur left)
-                      #;None
-                      (#;Some right)
-
-                      (#;Some =left)
-                      (|> (F;branch (set@ #F;tree =left queue)
-                                    (set@ #F;tree right queue))
-                          (get@ #F;tree)
-                          #;Some))
-                    (case (recur right)
-                      #;None
-                      (#;Some left)
-
-                      (#;Some =right)
-                      (|> (F;branch (set@ #F;tree left queue)
-                                    (set@ #F;tree =right queue))
-                          (get@ #F;tree)
-                          #;Some))
-                    )))]
-    (case node'
-      #;None
-      queue
-      
-      (#;Some node'')
-      (set@ #F;tree node'' queue))))
+  (do Monad<Maybe>
+    [fingers queue
+     #let [highest-priority (F;tag fingers)]
+     node' (loop [node (get@ #F;tree fingers)]
+             (case node
+               (#F;Leaf priority reference)
+               (if (n.= highest-priority priority)
+                 #;None
+                 (#;Some node))
+
+               (#F;Branch priority left right)
+               (if (n.= highest-priority (F;tag (set@ #F;tree left fingers)))
+                 (case (recur left)
+                   #;None
+                   (#;Some right)
+
+                   (#;Some =left)
+                   (|> (F;branch (set@ #F;tree =left fingers)
+                                 (set@ #F;tree right fingers))
+                       (get@ #F;tree)
+                       #;Some))
+                 (case (recur right)
+                   #;None
+                   (#;Some left)
+
+                   (#;Some =right)
+                   (|> (F;branch (set@ #F;tree left fingers)
+                                 (set@ #F;tree =right fingers))
+                       (get@ #F;tree)
+                       #;Some))
+                 )))]
+    (wrap (set@ #F;tree node' fingers))))
 
 (def: #export (push priority value queue)
   (All [a] (-> Priority a (Queue a) (Queue a)))
-  (F;branch queue (new priority value)))
+  (let [addition {#F;monoid number;Max@Monoid<Nat>
+                  #F;tree (#F;Leaf priority value)}]
+    (case queue
+      #;None
+      (#;Some addition)
+
+      (#;Some fingers)
+      (#;Some (F;branch fingers addition)))))
diff --git a/stdlib/source/lux/data/coll/seq.lux b/stdlib/source/lux/data/coll/seq.lux
index 1912a31a8..0e28d7f91 100644
--- a/stdlib/source/lux/data/coll/seq.lux
+++ b/stdlib/source/lux/data/coll/seq.lux
@@ -14,24 +14,27 @@
               ["s" syntax #+ syntax: Syntax])))
 
 (type: #export (Seq a)
-  (F;Fingers Nat a))
+  (Maybe (F;Fingers Nat a)))
 
 (def: default-size Nat +1)
 
-(def: #export (new value)
-  (All [a] (-> a (Seq a)))
+(def: (new value)
+  (All [a] (-> a (F;Fingers Nat a)))
   {#F;monoid number;Add@Monoid<Nat>
    #F;tree (#F;Leaf default-size value)})
 
 (do-template [<name> <side>]
   [(def: #export (<name> seq)
-     (All [a] (-> (Seq a) a))
-     (case (get@ #F;tree seq)
-       (#F;Leaf tag value)
-       value
-       
-       (#F;Branch tag left right)
-       (<name> (set@ #F;tree <side> seq))))]
+     (All [a] (-> (Seq a) (Maybe a)))
+     (do Monad<Maybe>
+       [fingers seq]
+       (wrap (loop [node (get@ #F;tree fingers)]
+               (case node
+                 (#F;Leaf tag value)
+                 value
+                 
+                 (#F;Branch tag left right)
+                 (recur <side>))))))]
 
   [first left]
   [last right]
@@ -39,34 +42,68 @@
 
 (def: #export (prepend prefix subject)
   (All [a] (-> a (Seq a) (Seq a)))
-  (F;branch (new prefix) subject))
+  (case subject
+    #;None
+    (#;Some (new prefix))
+
+    (#;Some fingers)
+    (#;Some (F;branch (new prefix) fingers))))
 
 (def: #export (append suffix subject)
   (All [a] (-> a (Seq a) (Seq a)))
-  (F;branch subject (new suffix)))
+  (case subject
+    #;None
+    (#;Some (new suffix))
+
+    (#;Some fingers)
+    (#;Some (F;branch fingers (new suffix)))))
+
+(def: #export (concat left right)
+  (All [a] (-> (Seq a) (Seq a) (Seq a)))
+  (case [left right]
+    [_ #;None]
+    left
+    
+    [#;None _]
+    right
+
+    [(#;Some left') (#;Some right')]
+    (#;Some (F;branch left' right'))))
 
 (def: #export (nth idx seq)
   (All [a] (-> Nat (Seq a) (Maybe a)))
-  (F;search (n.> idx) seq))
+  (do Monad<Maybe>
+    [fingers seq]
+    (F;search (n.> idx) fingers)))
 
 (def: #export (size seq)
   (All [a] (-> (Seq a) Nat))
-  (case (get@ #F;tree seq)
-    (^or (#F;Leaf tag value) (#F;Branch tag left right))
-    tag))
+  (case seq
+    #;None
+    +0
+
+    (#;Some fingers)
+    (case (get@ #F;tree fingers)
+      (^or (#F;Leaf tag value) (#F;Branch tag left right))
+      tag)))
 
 (def: #export (to-list seq)
   (All [a] (-> (Seq a) (List a)))
-  (loop [node (get@ #F;tree seq)]
-    (case node
-      (#F;Leaf tag value)
-      (list value)
-      
-      (#F;Branch tag left right)
-      (L/append (recur left) (recur right)))))
+  (case seq
+    #;None
+    (list)
+
+    (#;Some fingers)
+    (loop [node (get@ #F;tree fingers)]
+      (case node
+        (#F;Leaf tag value)
+        (list value)
+        
+        (#F;Branch tag left right)
+        (L/append (recur left) (recur right))))))
 
 (def: #export (from-list xs)
-  (All [a] (-> (List a) (Maybe (Seq a))))
+  (All [a] (-> (List a) (Seq a)))
   (loop [xs xs]
     (do Monad<Maybe>
       [[_ tree] (loop [xs xs]
@@ -92,71 +129,97 @@
 
 (def: #export (reverse seq)
   (All [a] (-> (Seq a) (Seq a)))
-  (|> seq to-list L;reverse from-list (default (undefined))))
+  (do Monad<Maybe>
+    [fingers seq
+     #let [node' (loop [node (get@ #F;tree fingers)]
+                   (case node
+                     (#F;Leaf tag value)
+                     node
+                     
+                     (#F;Branch tag left right)
+                     (#F;Branch tag (recur right) (recur left))))]]
+    (wrap (set@ #F;tree node' fingers))))
 
 (def: #export (member? Eq<a> xs x)
   (All [a] (-> (Eq a) (Seq a) a Bool))
-  (loop [xs (get@ #F;tree xs)]
-    (case xs
-      (#F;Leaf tag reference)
-      (:: Eq<a> = reference x)
+  (case xs
+    #;None
+    false
 
-      (#F;Branch tag left right)
-      (or (recur left)
-          (recur right)))))
+    (#;Some fingers)
+    (loop [xs (get@ #F;tree fingers)]
+      (case xs
+        (#F;Leaf tag reference)
+        (:: Eq<a> = reference x)
 
-(do-template [<name> <op>]
+        (#F;Branch tag left right)
+        (or (recur left)
+            (recur right))))))
+
+(do-template [<name> <op> <default>]
   [(def: #export (<name> pred seq)
      (All [a] (-> (-> a Bool) (Seq a) Bool))
-     (loop [seq (get@ #F;tree seq)]
-       (case seq
-         (#F;Leaf tag reference)
-         (pred reference)
-
-         (#F;Branch tag left right)
-         (<op> (recur left)
-               (recur right)))))]
-
-  [every? and]
-  [any?   or]
+     (case seq
+       #;None
+       <default>
+
+       (#;Some fingers)
+       (loop [seq (get@ #F;tree fingers)]
+         (case seq
+           (#F;Leaf tag reference)
+           (pred reference)
+
+           (#F;Branch tag left right)
+           (<op> (recur left)
+                 (recur right))))))]
+
+  [every? and true]
+  [any?   or  false]
   )
 
 (def: #export (sort < seq)
   (All [a] (-> (-> a a Bool) (Seq a) (Seq a)))
-  (|> seq to-list (L;sort <) from-list (default (undefined))))
+  (|> seq to-list (L;sort <) from-list))
 
 (def: #export (find pred seq)
   {#;doc "Returns the first value in the sequence for which the predicate is true."}
   (All [a]
     (-> (-> a Bool) (Seq a) (Maybe a)))
-  (loop [seq (get@ #F;tree seq)]
-    (case seq
-      (#F;Leaf tag value)
-      (if (pred value)
-        (#;Some value)
-        #;None)
+  (do Monad<Maybe>
+    [fingers seq]
+    (loop [seq (get@ #F;tree fingers)]
+      (case seq
+        (#F;Leaf tag value)
+        (if (pred value)
+          (#;Some value)
+          #;None)
 
-      (#F;Branch tag left right)
-      
-      (case (recur left)
-        #;None
-        (recur right)
+        (#F;Branch tag left right)
+        
+        (case (recur left)
+          #;None
+          (recur right)
 
-        output
-        output))))
+          output
+          output)))))
 
 (struct: #export _ (Fold Seq)
   (def: (fold f init seq)
-    (loop [init init
-           node (get@ #F;tree seq)]
-      (case node
-        (#F;Leaf tag value)
-        (f value init)
-        
-        (#F;Branch tag left right)
-        (recur (recur init left)
-               right)
-        ))))
+    (case seq
+      #;None
+      init
+
+      (#;Some fingers)
+      (loop [init init
+             node (get@ #F;tree fingers)]
+        (case node
+          (#F;Leaf tag value)
+          (f value init)
+          
+          (#F;Branch tag left right)
+          (recur (recur init left)
+                 right)
+          )))))
 
 (struct: #export (Eq<Seq> Eq<a>)
   (All [a] (-> (Eq a) (Eq (Seq a))))
@@ -167,41 +230,50 @@
 
 (struct: #export _ (Functor Seq)
   (def: (map f ma)
-    {#F;monoid number;Add@Monoid<Nat>
-     #F;tree (loop [tree (get@ #F;tree ma)]
-               (case tree
-                 (#F;Leaf tag value)
-                 (#F;Leaf tag (f value))
-                 
-                 (#F;Branch tag left right)
-                 (#F;Branch tag (recur left) (recur right))))}))
+    (do Monad<Maybe>
+      [fingers ma]
+      (wrap {#F;monoid number;Add@Monoid<Nat>
+             #F;tree (loop [tree (get@ #F;tree fingers)]
+                       (case tree
+                         (#F;Leaf tag value)
+                         (#F;Leaf tag (f value))
+                         
+                         (#F;Branch tag left right)
+                         (#F;Branch tag (recur left) (recur right))))}))))
 
 (struct: #export _ (Applicative Seq)
   (def: functor Functor<Seq>)
 
-  (def: wrap new)
+  (def: wrap (|>. new #;Some))
 
   (def: (apply ff fa)
-    (case (get@ #F;tree ff)
-      (#F;Leaf tag f)
-      (:: Functor<Seq> map f fa)
+    (do Monad<Maybe>
+      [ff' ff]
+      (case (get@ #F;tree ff')
+        (#F;Leaf tag f)
+        (:: Functor<Seq> map f fa)
 
-      (#F;Branch tag lfs rfs)
-      (F;branch (apply (set@ #F;tree lfs ff) fa)
-                (apply (set@ #F;tree rfs ff) fa)))))
+        (#F;Branch tag lfs rfs)
+        (do @
+          [lefts (apply (#;Some (set@ #F;tree lfs ff')) fa)
+           rights (apply (#;Some (set@ #F;tree rfs ff')) fa)]
+          (wrap (F;branch lefts rights)))))))
 
 (struct: #export _ (Monad Seq)
   (def: applicative Applicative<Seq>)
 
   (def: (join ffa)
-    (case (get@ #F;tree ffa)
-      (#F;Leaf tag fa)
-      fa
-      
-      (#F;Branch tag left right)
-      (F;branch (join (set@ #F;tree left ffa))
-                (join (set@ #F;tree right ffa))))))
-
-(syntax: #export (seq [elems (s;many s;any)])
-  (wrap (list (` (default (undefined)
-                   (;;from-list (list (~@ elems))))))))
+    (do Monad<Maybe>
+      [ffa' ffa]
+      (case (get@ #F;tree ffa')
+        (#F;Leaf tag fa)
+        fa
+        
+        (#F;Branch tag left right)
+        (do @
+          [left' (join (#;Some (set@ #F;tree left ffa')))
+           right' (join (#;Some (set@ #F;tree right ffa')))]
+          (wrap (F;branch left' right')))))))
+
+(syntax: #export (seq [elems (s;some s;any)])
+  (wrap (list (` (;;from-list (list (~@ elems)))))))
-- 
cgit v1.2.3