Created the "lux/abstract" branch and moved some modules into it.

1 files changed, 168 insertions, 0 deletions

diff --git a/stdlib/source/lux/abstract/monad.lux b/stdlib/source/lux/abstract/monad.lux
new file mode 100644
index 000000000..0e509c64e
--- /dev/null
+++ b/stdlib/source/lux/abstract/monad.lux
@@ -0,0 +1,168 @@
+(.module:
+  [lux #*]
+  [//
+   ["." functor (#+ Functor)]])
+
+(def: (list;fold f init xs)
+  (All [a b]
+    (-> (-> b a a) a (List b) a)) 
+  (case xs
+    #.Nil
+    init
+
+    (#.Cons x xs')
+    (list;fold f (f x init) xs')))
+
+(def: (list;size xs)
+  (All [a] (-> (List a) Nat))
+  (loop [counter 0
+         xs xs]
+    (case xs
+      #.Nil
+      counter
+
+      (#.Cons _ xs')
+      (recur (inc counter) xs'))))
+
+(def: (reverse xs)
+  (All [a]
+    (-> (List a) (List a)))
+  (list;fold (function (_ head tail) (#.Cons head tail))
+             #.Nil
+             xs))
+
+(def: (as-pairs xs)
+  (All [a] (-> (List a) (List [a a])))
+  (case xs
+    (#.Cons x1 (#.Cons x2 xs'))
+    (#.Cons [x1 x2] (as-pairs xs'))
+
+    _
+    #.Nil))
+
+(signature: #export (Monad m)
+  (: (Functor m)
+     &functor)
+  (: (All [a]
+       (-> a (m a)))
+     wrap)
+  (: (All [a]
+       (-> (m (m a)) (m a)))
+     join))
+
+(def: _cursor Cursor ["" 0 0])
+
+(macro: #export (do tokens state)
+  {#.doc (doc "Macro for easy concatenation of monadic operations."
+              (do monad
+                [y (f1 x)
+                 z (f2 z)]
+                (wrap (f3 z))))}
+  (case tokens
+    (#.Cons monad (#.Cons [_ (#.Tuple bindings)] (#.Cons body #.Nil)))
+    (if (|> bindings list;size (n/% 2) (n/= 0))
+      (let [g!_ (: Code [_cursor (#.Identifier ["" " _ "])])
+            g!map (: Code [_cursor (#.Identifier ["" " map "])])
+            g!join (: Code [_cursor (#.Identifier ["" " join "])])
+            body' (list;fold (: (-> [Code Code] Code Code)
+                                (function (_ binding body')
+                                  (let [[var value] binding]
+                                    (case var
+                                      [_ (#.Tag ["" "let"])]
+                                      (` (let (~ value) (~ body')))
+
+                                      _
+                                      (` (|> (~ value) ((~ g!map) (function ((~ g!_) (~ var)) (~ body'))) (~ g!join)))
+                                      ))))
+                             body
+                             (reverse (as-pairs bindings)))]
+        (#.Right [state (#.Cons (` ({(~' @)
+                                     ({{#..&functor {#functor.map (~ g!map)}
+                                        #..wrap (~' wrap)
+                                        #..join (~ g!join)}
+                                       (~ body')}
+                                      (~' @))}
+                                    (~ monad)))
+                                #.Nil)]))
+      (#.Left "'do' bindings must have an even number of parts."))
+
+    _
+    (#.Left "Wrong syntax for 'do'")))
+
+(def: #export (seq monad)
+  {#.doc "Run all the monadic values in the list and produce a list of the base values."}
+  (All [M a]
+    (-> (Monad M) (List (M a))
+        (M (List a))))
+  (let [(^open "!;.") monad]
+    (function (recur xs)
+      (case xs
+        #.Nil
+        (!;wrap #.Nil)
+        
+        (#.Cons x xs')
+        (|> x
+            (!;map (function (_ _x)
+                     (!;map (|>> (#.Cons _x)) (recur xs'))))
+            !;join)))))
+
+(def: #export (map monad f)
+  {#.doc "Apply a monadic function to all values in a list."}
+  (All [M a b]
+    (-> (Monad M) (-> a (M b)) (List a)
+        (M (List b))))
+  (let [(^open "!;.") monad]
+    (function (recur xs)
+      (case xs
+        #.Nil
+        (!;wrap #.Nil)
+        
+        (#.Cons x xs')
+        (|> (f x)
+            (!;map (function (_ _x)
+                     (!;map (|>> (#.Cons _x)) (recur xs'))))
+            !;join)))))
+
+(def: #export (filter Monad<!> f)
+  {#.doc "Filter the values in a list with a monadic function."}
+  (All [! a b]
+    (-> (Monad !) (-> a (! Bit)) (List a)
+        (! (List a))))
+  (let [(^open "!;.") Monad<!>]
+    (function (recur xs)
+      (case xs
+        #.Nil
+        (!;wrap #.Nil)
+        
+        (#.Cons head xs')
+        (|> (f head)
+            (!;map (function (_ verdict)
+                     (!;map (function (_ tail)
+                              (if verdict
+                                (#.Cons head tail)
+                                tail))
+                            (recur xs'))))
+            !;join)))))
+
+(def: #export (fold monad f init xs)
+  {#.doc "Fold a list with a monadic function."}
+  (All [M a b]
+    (-> (Monad M) (-> b a (M a)) a (List b)
+        (M a)))
+  (case xs
+    #.Nil
+    (:: monad wrap init)
+
+    (#.Cons x xs')
+    (do monad
+      [init' (f x init)]
+      (fold monad f init' xs'))))
+
+(def: #export (lift monad f)
+  {#.doc "Lift a normal function into the space of monads."}
+  (All [M a b]
+    (-> (Monad M) (-> a b) (-> (M a) (M b))))
+  (function (_ ma)
+    (do monad
+      [a ma]
+      (wrap (f a)))))