1 files changed, 89 insertions, 0 deletions
diff --git a/stdlib/source/lux/control/cont.lux b/stdlib/source/lux/control/cont.lux
new file mode 100644
index 000000000..08f784035
--- /dev/null
+++ b/stdlib/source/lux/control/cont.lux
@@ -0,0 +1,89 @@
+(;module:
+  lux
+  (lux (control functor
+                applicative
+                monad)
+       function
+       [compiler #+ with-gensyms]
+       (macro [ast]
+              [syntax #+ syntax:])))
+
+(type: #export (Cont i o)
+  {#;doc "Continuations."}
+  (-> (-> i o) o))
+
+(def: #export (continue k cont)
+  {#;doc "Forces a continuation thunk to be evaluated."}
+  (All [i o] (-> (-> i o) (Cont i o) o))
+  (cont k))
+
+(def: #export (run cont)
+  {#;doc "Forces a continuation thunk to be evaluated."}
+  (All [a] (-> (Cont a a) a))
+  (cont id))
+
+(struct: #export Functor<Cont> (All [o] (Functor (All [i] (Cont i o))))
+  (def: (map f fv)
+    (function [k] (fv (. k f)))))
+
+(struct: #export Applicative<Cont> (All [o] (Applicative (All [i] (Cont i o))))
+  (def: functor Functor<Cont>)
+
+  (def: (wrap value)
+    (function [k] (k value)))
+
+  (def: (apply ff fv)
+    (function [k]
+      (|> (k (f v))
+          (function [v]) fv
+          (function [f]) ff))))
+
+(struct: #export Monad<Cont> (All [o] (Monad (All [i] (Cont i o))))
+  (def: applicative Applicative<Cont>)
+
+  (def: (join ffa)
+    (function [k]
+      (ffa (continue k)))))
+
+(def: #export (call/cc f)
+  {#;doc "Call with current continuation."}
+  (All [a b z]
+    (-> (-> (-> a (Cont b z))
+            (Cont a z))
+        (Cont a z)))
+  (function [k]
+    (f (function [a] (function [_] (k a)))
+       k)))
+
+(syntax: #export (pending expr)
+  {#;doc (doc "Turns any expression into a function that is pending a continuation."
+              (pending (some-computation some-input)))}
+  (with-gensyms [g!k]
+    (wrap (list (` (;function [(~ g!k)] ((~ g!k) (~ expr))))))))
+
+(def: #export (portal init)
+  (All [i o z]
+    (-> i
+        (Cont [(-> i (Cont o z))
+               i]
+              z)))
+  (call/cc (function [k]
+             (do Monad<Cont>
+               [#let [nexus (function nexus [val]
+                              (k [nexus val]))]
+                _ (k [nexus init])]
+               (wrap (undefined))))))
+
+(def: #export (reset scope)
+  (All [i o] (-> (Cont i i) (Cont i o)))
+  (function [k]
+    (k (run scope))))
+
+(def: #export (shift f)
+  (All [a]
+    (-> (-> (-> a (Cont a a))
+            (Cont a a))
+        (Cont a a)))
+  (function [oc]
+    (f (function [a] (function [ic] (ic (oc a))))
+       id)))