1 files changed, 54 insertions, 0 deletions
diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux
new file mode 100644
index 000000000..1830ff44f
--- /dev/null
+++ b/source/lux/control/comonad.lux
@@ -0,0 +1,54 @@
+##   Copyright (c) Eduardo Julian. All rights reserved.
+##   The use and distribution terms for this software are covered by the
+##   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+##   which can be found in the file epl-v10.html at the root of this distribution.
+##   By using this software in any fashion, you are agreeing to be bound by
+##   the terms of this license.
+##   You must not remove this notice, or any other, from this software.
+
+(;import lux
+         (../functor #as F)
+         lux/data/list
+         lux/meta/macro)
+
+## Signatures
+(defsig #export (CoMonad w)
+  (: (F;Functor w)
+     _functor)
+  (: (All [a]
+       (-> (w a) a))
+     unwrap)
+  (: (All [a]
+       (-> (w a) (w (w a))))
+     split))
+
+## Functions
+(def #export (extend w f ma)
+  (All [w a b]
+    (-> (CoMonad w) (-> (w a) b) (w a) (w b)))
+  (using w
+    (using ;;_functor
+      (F;map f (;;split ma)))))
+
+## Syntax
+(defmacro #export (be tokens state)
+  (case tokens
+    (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body))
+    (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+                          (lambda [body' binding]
+                            (let [[var value] binding]
+                              (case var
+                                (#;Meta [_ (#;TagS ["" "let"])])
+                                (` (;let (~ value) (~ body')))
+
+                                _
+                                (` (extend (;lambda [(~ var)] (~ body'))
+                                           (~ value)))))))
+                       body
+                       (reverse (as-pairs bindings)))]
+      (#;Right [state (list (` (;case (~ monad)
+                                      {#;return ;return #;bind ;bind}
+                                      (~ body'))))]))
+
+    _
+    (#;Left "Wrong syntax for be")))