From cc928a8675cb35dabd4a4957ab6612b70f015d58 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 29 Aug 2015 18:12:27 -0400
Subject: - Removed the (unnecessary) lux/data/cont module. - Removed the
 (unnecessary) lux/data/error module and moved it's structures to
 lux/data/either. - Implemented the \slots destructurer for records. -
 Implemented quicksort for lists as the "sort" function in lux/data/list. -
 Added tags for the Cursor type.

---
 source/lux.lux             | 45 +++++++++++++++++++++++++++++++++++++++++----
 source/lux/data/cont.lux   | 38 --------------------------------------
 source/lux/data/either.lux | 42 +++++++++++++++++++++++++++++++-----------
 source/lux/data/error.lux  | 31 -------------------------------
 source/lux/data/list.lux   | 24 +++++++++++++++++++++---
 5 files changed, 93 insertions(+), 87 deletions(-)
 delete mode 100644 source/lux/data/cont.lux
 delete mode 100644 source/lux/data/error.lux

(limited to 'source')

diff --git a/source/lux.lux b/source/lux.lux
index d96b18fcb..cf56f326a 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -160,6 +160,7 @@
   (#NamedT ["lux" "Cursor"]
            (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil))))))
 (_lux_export Cursor)
+(_lux_declare-tags [#module #line #column] Cursor)
 
 ## (deftype (Meta m v)
 ##   (| (#Meta m v)))
@@ -785,8 +786,8 @@
     (#Meta _ (#RecordS pairs))
     (record$ (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil))))
                           (lambda'' [pair]
-                               (let'' [name val] pair
-                                      [name (update-bounds val)])))
+                                    (let'' [name val] pair
+                                           [name (update-bounds val)])))
                   pairs))
 
     (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "lux" "BoundT")) (#Cons (#Meta _ (#IntS idx)) #Nil))))
@@ -931,8 +932,8 @@
 (def''' (as-pairs xs)
   (All' [a] (->' ($' List a) ($' List (#TupleT (list a a)))))
   (_lux_case xs
-    (#Cons [x (#Cons [y xs'])])
-    (#Cons [[x y] (as-pairs xs')])
+    (#Cons x (#Cons y xs'))
+    (#Cons [x y] (as-pairs xs'))
 
     _
     #Nil))
@@ -3224,3 +3225,39 @@
 
 (defmacro #export (export tokens)
   (return (map (lambda [token] (` (_lux_export (~ token)))) tokens)))
+
+(defmacro #export (\slots tokens)
+  (case tokens
+    (\ (list body (#Meta _ (#TupleS (list& hslot' tslots')))))
+    (do Lux/Monad
+      [slots (: (Lux (, Ident (List Ident)))
+                (case (: (Maybe (, Ident (List Ident)))
+                         (do Maybe/Monad
+                           [hslot (get-ident hslot')
+                            tslots (map% Maybe/Monad get-ident tslots')]
+                           (wrap [hslot tslots])))
+                  (#Some slots)
+                  (return slots)
+                  
+                  #None
+                  (fail "Wrong syntax for \\slots")))
+       #let [[hslot tslots] slots]
+       hslot (normalize hslot)
+       tslots (map% Lux/Monad normalize tslots)
+       output (resolve-tag hslot)
+       g!_ (gensym "_")
+       #let [[idx tags type] output
+             slot-pairings (map (: (-> Ident (, Text AST))
+                                   (lambda [[module name]] [name (symbol$ ["" name])]))
+                                (list& hslot tslots))
+             pattern (record$ (map (: (-> Ident (, AST AST))
+                                      (lambda [[module name]]
+                                        (let [tag (tag$ [module name])]
+                                          (case (get name slot-pairings)
+                                            (#Some binding) [tag binding]
+                                            #None           [tag g!_]))))
+                                   tags))]]
+      (return (list pattern body)))
+    
+    _
+    (fail "Wrong syntax for \\slots")))
diff --git a/source/lux/data/cont.lux b/source/lux/data/cont.lux
deleted file mode 100644
index 2c55eb641..000000000
--- a/source/lux/data/cont.lux
+++ /dev/null
@@ -1,38 +0,0 @@
-##  Copyright (c) Eduardo Julian. All rights reserved.
-##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-##  If a copy of the MPL was not distributed with this file,
-##  You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(;import lux
-         (lux/control (functor #as F #refer #all)
-                      (monad #as M #refer #all)))
-
-## [Types]
-(deftype #export (Cont r a)
-  (-> (-> a r) r))
-
-## [Structures]
-(defstruct #export Cont/Functor (All [r]
-                                  (Functor (Cont r)))
-  (def (F;map f fa)
-    (lambda [k]
-      (k (fa f)))))
-
-(defstruct #export Cont/Monad (All [r]
-                                (Monad (Cont r)))
-  (def M;_functor Cont/Functor)
-
-  (def (M;wrap x)
-    (lambda [k]
-      (k x)))
-
-  (def (M;join mma)
-    (lambda [k]
-      (mma (lambda [ma] (ma k))))))
-
-## [Functions]
-(def #export (call/cc body)
-  (All [r a b]
-    (-> (-> (-> a (Cont r b)) (Cont r a)) (Cont r a)))
-  (lambda [k]
-    (body k)))
diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux
index a945c32b9..86d778965 100644
--- a/source/lux/data/either.lux
+++ b/source/lux/data/either.lux
@@ -4,7 +4,9 @@
 ##  You can obtain one at http://mozilla.org/MPL/2.0/.
 
 (;import lux
-         (lux/data (list #refer (#exclude partition))))
+         (lux (control (functor #as F #refer #all)
+                       (monad #as M #refer #all))
+              (data (list #refer (#exclude partition)))))
 
 ## [Types]
 ## (deftype (Either l r)
@@ -30,14 +32,32 @@
   [rights b #;Right]
   )
 
-(def #export (partition es)
+(def #export (partition xs)
   (All [a b] (-> (List (Either a b)) (, (List a) (List b))))
-  (foldL (: (All [a b]
-              (-> (, (List a) (List b)) (Either a b) (, (List a) (List b))))
-            (lambda [tails e]
-              (let [[ltail rtail] tails]
-                (case e
-                  (#;Left x)  [(#;Cons [x ltail]) rtail]
-                  (#;Right x) [ltail (#;Cons [x rtail])]))))
-         [(list) (list)]
-         (reverse es)))
+  (case xs
+    #;Nil
+    [#;Nil #;Nil]
+
+    (#;Cons x xs')
+    (let [[lefts rights] (partition xs')]
+      (case x
+        (#;Left x')  [(#;Cons x' lefts) rights]
+        (#;Right x') [lefts (#;Cons x' rights)]))))
+
+## [Structures]
+(defstruct #export Error/Functor (All [a] (Functor (Either a)))
+  (def (F;map f ma)
+    (case ma
+      (#;Left msg)    (#;Left msg)
+      (#;Right datum) (#;Right (f datum)))))
+
+(defstruct #export Error/Monad (All [a] (Monad (Either a)))
+  (def M;_functor Error/Functor)
+
+  (def (M;wrap a)
+    (#;Right a))
+
+  (def (M;join mma)
+    (case mma
+      (#;Left msg) (#;Left msg)
+      (#;Right ma) ma)))
diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux
deleted file mode 100644
index 9c595144b..000000000
--- a/source/lux/data/error.lux
+++ /dev/null
@@ -1,31 +0,0 @@
-##  Copyright (c) Eduardo Julian. All rights reserved.
-##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
-##  If a copy of the MPL was not distributed with this file,
-##  You can obtain one at http://mozilla.org/MPL/2.0/.
-
-(;import lux
-         (lux/control (functor #as F #refer #all)
-                      (monad #as M #refer #all)))
-
-## [Types]
-(deftype #export (Error a)
-  (| (#Fail Text)
-     (#Ok a)))
-
-## [Structures]
-(defstruct #export Error/Functor (Functor Error)
-  (def (F;map f ma)
-    (case ma
-      (#Fail msg) (#Fail msg)
-      (#Ok datum) (#Ok (f datum)))))
-
-(defstruct #export Error/Monad (Monad Error)
-  (def M;_functor Error/Functor)
-
-  (def (M;wrap a)
-    (#Ok a))
-
-  (def (M;join mma)
-    (case mma
-      (#Fail msg) (#Fail msg)
-      (#Ok ma)    ma)))
diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux
index a4a6a6d0e..1277fc6ae 100644
--- a/source/lux/data/list.lux
+++ b/source/lux/data/list.lux
@@ -8,6 +8,7 @@
                        (functor #as F #refer #all)
                        (monad #as M #refer #all)
                        (eq #as E)
+                       (ord #as O)
                        (dict #as D #refer #all)
                        (stack #as S))
               (data (number (int #open ("i" Int/Number Int/Ord)))
@@ -248,9 +249,12 @@
 ##       [#;Nil #;Nil]
 ##       true
 
-##       [(#;Cons [x xs']) (#;Cons [y ys'])]
+##       [(#;Cons x xs') (#;Cons y ys')]
 ##       (and (:: eq (E;= x y))
 ##            (E;= xs' ys'))
+
+##       [_ _]
+##       false
 ##       )))
 
 (defstruct #export List/Monoid (All [a]
@@ -258,8 +262,8 @@
   (def m;unit #;Nil)
   (def (m;++ xs ys)
     (case xs
-      #;Nil            ys
-      (#;Cons [x xs']) (#;Cons [x (++ xs' ys)]))))
+      #;Nil          ys
+      (#;Cons x xs') (#;Cons x (++ xs' ys)))))
 
 (defstruct #export List/Functor (Functor List)
   (def (F;map f ma)
@@ -327,3 +331,17 @@
     (case xs
       #;Nil          #;None
       (#;Cons x xs') (#;Some x))))
+
+## [Functions]
+(def #export (sort ord xs)
+  (All [a] (-> (O;Ord a) (List a) (List a)))
+  (case xs
+    #;Nil
+    #;Nil
+    
+    (#;Cons x xs')
+    (using ord
+      (let [pre (filter (>= x) xs')
+            post (filter (< x) xs')
+            ++ (:: List/Monoid m;++)]
+        ($ ++ (sort ord pre) (list x) (sort ord post))))))
-- 
cgit v1.2.3