From d4c23b4cce91ae8cfcf1bda6b577ff50c55abe3c Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sun, 9 Apr 2017 19:41:15 -0400
Subject: - Added delimited continuations, with static shifting.

---
 stdlib/source/lux/function/cont.lux    |  34 ++++++++---
 stdlib/test/test/lux/function/cont.lux | 108 +++++++++++++++++++++------------
 2 files changed, 93 insertions(+), 49 deletions(-)

diff --git a/stdlib/source/lux/function/cont.lux b/stdlib/source/lux/function/cont.lux
index 9074f59f0..911e66995 100644
--- a/stdlib/source/lux/function/cont.lux
+++ b/stdlib/source/lux/function/cont.lux
@@ -22,16 +22,6 @@
   (All [a] (-> (Cont a a) a))
   (cont id))
 
-(def: #export (call/cc f)
-  {#;doc "Call with current continuation."}
-  (All [a b z]
-    (-> (-> (-> a (Cont b z))
-            (Cont a z))
-        (Cont a z)))
-  (lambda [k]
-    (f (lambda [a] (lambda [_] (k a)))
-       k)))
-
 (struct: #export Functor<Cont> (All [o] (Functor (All [i] (Cont i o))))
   (def: (map f fv)
     (lambda [k] (fv (. k f)))))
@@ -55,6 +45,16 @@
     (lambda [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)))
+  (lambda [k]
+    (f (lambda [a] (lambda [_] (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)))}
@@ -73,3 +73,17 @@
                               (k [nexus val]))]
                 _ (k [nexus init])]
                (wrap (undefined))))))
+
+(def: #export (reset scope)
+  (All [i o] (-> (Cont i i) (Cont i o)))
+  (lambda [k]
+    (k (run scope))))
+
+(def: #export (static f)
+  (All [a]
+    (-> (-> (-> a (Cont a a))
+            (Cont a a))
+        (Cont a a)))
+  (lambda [oc]
+    (f (lambda [a] (lambda [ic] (ic (oc a))))
+       id)))
diff --git a/stdlib/test/test/lux/function/cont.lux b/stdlib/test/test/lux/function/cont.lux
index 97058c22f..6404ed2ac 100644
--- a/stdlib/test/test/lux/function/cont.lux
+++ b/stdlib/test/test/lux/function/cont.lux
@@ -5,48 +5,78 @@
        (data [text "Text/" Monoid<Text>]
              text/format
              [number]
-             [product])
+             [product]
+             (coll [list]))
        (function ["&" cont])
        ["R" math/random])
   lux/test)
 
 (test: "Continuations"
   [sample R;nat
-   #let [(^open "&/") &;Monad<Cont>]]
-  ($_ seq
-      (assert "Can run continuations to compute their values."
-              (n.= sample (&;run (&/wrap sample))))
-
-      (assert "Can use functor."
-              (n.= (n.inc sample) (&;run (&/map n.inc (&/wrap sample)))))
-
-      (assert "Can use applicative."
-              (n.= (n.inc sample) (&;run (&/apply (&/wrap n.inc) (&/wrap sample)))))
-
-      (assert "Can use monad."
-              (n.= (n.inc sample) (&;run (do &;Monad<Cont>
-                                           [func (wrap n.inc)
-                                            arg (wrap sample)]
-                                           (wrap (func arg))))))
-
-      (assert "Can use the current-continuation as a escape hatch."
-              (n.= (n.* +2 sample)
-                   (&;run (do &;Monad<Cont>
-                            [value (&;call/cc
-                                    (lambda [k]
-                                      (do @
-                                        [temp (k sample)]
-                                        ## If this code where to run,
-                                        ## the output would be
-                                        ## (n.* +4 sample)
-                                        (k temp))))]
-                            (wrap (n.* +2 value))))))
-
-      (assert "Can use the current-continuation to build a time machine."
-              (n.= (n.+ +100 sample)
-                   (&;run (do &;Monad<Cont>
-                            [[restart [output idx]] (&;portal [sample +0])]
-                            (if (n.< +10 idx)
-                              (restart [(n.+ +10 output) (n.inc idx)])
-                              (wrap output))))))
-      ))
+   #let [(^open "&/") &;Monad<Cont>]
+   elems (R;list +3 R;nat)]
+  (let% [<delimited-tests> (do-template [<desc> <shift> <prepare>]
+                             [(assert <desc>
+                                      (let [(^open "&/") &;Monad<Cont>
+                                            (^open "L/") (list;Eq<List> number;Eq<Nat>)
+                                            visit (: (-> (List Nat) (&;Cont (List Nat) (List Nat)))
+                                                     (lambda visit [xs]
+                                                       (case xs
+                                                         #;Nil
+                                                         (&/wrap #;Nil)
+
+                                                         (#;Cons x xs')
+                                                         (do &;Monad<Cont>
+                                                           [output (<shift> (lambda [k]
+                                                                              (do &;Monad<Cont>
+                                                                                [tail (k xs')]
+                                                                                (wrap (#;Cons x tail)))))]
+                                                           (visit output)))))]
+                                        (L/= (<prepare> elems)
+                                             (&;run (&;reset (visit elems))))
+                                        ))]
+
+                             ["Can use delimited continuations with static shifting."
+                              &;static id]
+                             ## ["Can use delimited continuations with dynamic shifting."
+                             ##  &;dynamic list;reverse]
+                             )]
+    ($_ seq
+        (assert "Can run continuations to compute their values."
+                (n.= sample (&;run (&/wrap sample))))
+
+        (assert "Can use functor."
+                (n.= (n.inc sample) (&;run (&/map n.inc (&/wrap sample)))))
+
+        (assert "Can use applicative."
+                (n.= (n.inc sample) (&;run (&/apply (&/wrap n.inc) (&/wrap sample)))))
+
+        (assert "Can use monad."
+                (n.= (n.inc sample) (&;run (do &;Monad<Cont>
+                                             [func (wrap n.inc)
+                                              arg (wrap sample)]
+                                             (wrap (func arg))))))
+
+        (assert "Can use the current-continuation as a escape hatch."
+                (n.= (n.* +2 sample)
+                     (&;run (do &;Monad<Cont>
+                              [value (&;call/cc
+                                      (lambda [k]
+                                        (do @
+                                          [temp (k sample)]
+                                          ## If this code where to run,
+                                          ## the output would be
+                                          ## (n.* +4 sample)
+                                          (k temp))))]
+                              (wrap (n.* +2 value))))))
+
+        (assert "Can use the current-continuation to build a time machine."
+                (n.= (n.+ +100 sample)
+                     (&;run (do &;Monad<Cont>
+                              [[restart [output idx]] (&;portal [sample +0])]
+                              (if (n.< +10 idx)
+                                (restart [(n.+ +10 output) (n.inc idx)])
+                                (wrap output))))))
+
+        <delimited-tests>
+        )))
-- 
cgit v1.2.3