X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=blobdiff_plain;f=code%2Fmonads.ml;h=8b69ec1d1a0a909b62ae7353b3487e6c642169d5;hp=be3753296e8cb599738cb5e73a5f53026cdfcfee;hb=372c2fd214b65657211aa550fc1dccfb6e3cbfda;hpb=10906eaaea38d130ae301688749a94e6450447c2

diff --git a/code/monads.ml b/code/monads.ml
index be375329..8b69ec1d 100644
--- a/code/monads.ml
+++ b/code/monads.ml
@@ -342,6 +342,7 @@ module List_monad : sig
     val permute : 'a m -> 'a m m
     val select : 'a m -> ('a * 'a m) m
 *)
+    val expose : ('x,'a) m -> ('x,'a list) Wrapped.m
   end
 end = struct
   module Base = struct
@@ -412,6 +413,7 @@ end = struct
     let permute : 'a m -> 'a m m
     let select : 'a m -> ('a * 'a m) m
 *)
+    let expose u = u
   end
 end
 
@@ -530,6 +532,7 @@ module Reader_monad(Env : sig type env end) : sig
     val ask : ('x,env) m
     val asks : (env -> 'a) -> ('x,'a) m
     val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
+    val expose : ('x,'a) m -> env -> ('x,'a) Wrapped.m
   end
 end = struct
   type env = Env.env
@@ -568,6 +571,7 @@ end = struct
     let asks selector = ask >>= (fun e ->
       try unit (selector e)
       with Not_found -> fun e -> Wrapped.zero ())
+    let expose u = u
   end
 end
 
@@ -593,6 +597,8 @@ module State_monad(Store : sig type store end) : sig
     val gets : (store -> 'a) -> ('x,'a) m
     val put : store -> ('x,unit) m
     val puts : (store -> store) -> ('x,unit) m
+    (* val passthru : ('x,'a) m -> (('x,'a * store) Wrapped.result * store -> 'b) -> ('x,'b) m *)
+    val expose : ('x,'a) m -> store -> ('x,'a * store) Wrapped.m
   end
 end = struct
   type store = Store.store
@@ -637,6 +643,8 @@ end = struct
       with Not_found -> Wrapped.zero ()
     let put s = fun _ -> Wrapped.unit ((), s)
     let puts modifier = fun s -> Wrapped.unit ((), modifier s)
+    (* let passthru u f = fun s -> Wrapped.unit (f (Wrapped.run (u s), s), s) *)
+    let expose u = u
   end
 end
 
@@ -949,42 +957,6 @@ end
  *   >>= fun x -> unit (x, 0)
  *   in run u)
  *
- *
- * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
- * let example1 () : int =
- *   Continuation_monad.(let v = reset (
- *       let u = shift (fun k -> unit (10 + 1))
- *       in u >>= fun x -> unit (100 + x)
- *     ) in let w = v >>= fun x -> unit (1000 + x)
- *     in run w)
- *
- * (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
- * let example2 () =
- *   Continuation_monad.(let v = reset (
- *       let u = shift (fun k -> k (10 :: [1]))
- *       in u >>= fun x -> unit (100 :: x)
- *     ) in let w = v >>= fun x -> unit (1000 :: x)
- *     in run w)
- *
- * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
- * let example3 () =
- *   Continuation_monad.(let v = reset (
- *       let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
- *       in u >>= fun x -> unit (100 :: x)
- *     ) in let w = v >>= fun x -> unit (1000 :: x)
- *     in run w)
- *
- * (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
- * (* not sure if this example can be typed without a sum-type *)
- *
- * (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
- * let example5 () : int =
- *   Continuation_monad.(let v = reset (
- *       let u = shift (fun k -> k 1 >>= fun x -> k x)
- *       in u >>= fun x -> unit (10 + x)
- *     ) in let w = v >>= fun x -> unit (100 + x)
- *     in run w)
- *
  *)
 
 
@@ -1004,6 +976,7 @@ module Tree_monad : sig
     (* note that second argument is an 'a tree?, not the more abstract 'a m *)
     (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
     val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
+    val expose : ('x,'a) m -> ('x,'a tree option) Wrapped.m
   end
 end = struct
   type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
@@ -1062,90 +1035,8 @@ end = struct
     end
     include BaseT
     let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
+    let expose u = u
   end
 end;;
 
 
-
-module C = Continuation_monad;;
-
-
-print_endline "=== test TreeT(Continuation).distribute ==================";;
-
-let id : 'z. 'z -> 'z = fun x -> x
-
-let example n : (int * int) =
-  Continuation_monad.(let u = callcc (fun k ->
-      (if n < 0 then k 0 else unit [n + 100])
-      (* all of the following is skipped by k 0; the end type int is k's input type *)
-      >>= fun [x] -> unit (x + 1)
-  )
-  (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
-  >>= fun x -> unit (x, 0)
-  in run0 u)
-
-
-(* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
-let example1 () : int =
-  Continuation_monad.(let v = reset (
-      let u = shift (fun k -> unit (10 + 1))
-      in u >>= fun x -> unit (100 + x)
-    ) in let w = v >>= fun x -> unit (1000 + x)
-    in run0 w)
-
-(* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
-let example2 () =
-  Continuation_monad.(let v = reset (
-      let u = shift (fun k -> k (10 :: [1]))
-      in u >>= fun x -> unit (100 :: x)
-    ) in let w = v >>= fun x -> unit (1000 :: x)
-    in run0 w)
-
-(* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
-let example3 () =
-  Continuation_monad.(let v = reset (
-      let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
-      in u >>= fun x -> unit (100 :: x)
-    ) in let w = v >>= fun x -> unit (1000 :: x)
-    in run0 w)
-
-(* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
-(* not sure if this example can be typed without a sum-type *)
-
-(* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
-let example5 () : int =
-  Continuation_monad.(let v = reset (
-      let u = shift (fun k -> k 1 >>= k)
-      in u >>= fun x -> unit (10 + x)
-    ) in let w = v >>= fun x -> unit (100 + x)
-    in run0 w)
-
-;;
-
-print_endline "=== test bare Continuation ============";;
-
-(1011, 1111, 1111, 121);;
-(example1(), example2(), example3(), example5());;
-((111,0), (0,0));;
-(example ~+10, example ~-10);;
-
-
-print_endline "=== pa_monad's Continuation Tests ============";;
-
-(1, 5 = C.(run0 (unit 1 >>= fun x -> unit (x+4))) );;
-(2, 9 = C.(run0 (reset (unit 5 >>= fun x -> unit (x+4)))) );;
-(3, 9 = C.(run0 (reset (abort 5 >>= fun y -> unit (y+6)) >>= fun x -> unit (x+4))) );;
-(4, 9 = C.(run0 (reset (reset (abort 5 >>= fun y -> unit (y+6))) >>= fun x -> unit (x+4))) );;
-(5, 27 = C.(run0 (
-              let c = reset(abort 5 >>= fun y -> unit (y+6))
-              in reset(c >>= fun v1 -> abort 7 >>= fun v2 -> unit (v2+10) ) >>= fun x -> unit (x+20))) );;
-
-(7, 117 = C.(run0 (reset (shift (fun sk -> sk 3 >>= sk >>= fun v3 -> unit (v3+100) ) >>= fun v1 -> unit (v1+2)) >>= fun x -> unit (x+10))) );;
-
-(8, 115 = C.(run0 (reset (shift (fun sk -> sk 3 >>= fun v3 -> unit (v3+100)) >>= fun v1 -> unit (v1+2)) >>= fun x -> unit (x+10))) );;
-
-(12, ["a"] = C.(run0 (reset (shift (fun f -> f [] >>= fun t -> unit ("a"::t)  ) >>= fun xv -> shift (fun _ -> unit xv)))) );;
-
-
-(0, 15 = C.(run0 (let f k = k 10 >>= fun v-> unit (v+100) in reset (callcc f >>= fun v -> unit (v+5)))) );;
-