From: Jim Pryor <profjim@jimpryor.net>
Date: Thu, 23 Dec 2010 20:49:35 +0000 (-0500)
Subject: add expose to monads.ml
X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=commitdiff_plain;h=372c2fd214b65657211aa550fc1dccfb6e3cbfda

add expose to monads.ml

Signed-off-by: Jim Pryor <profjim@jimpryor.net>
---

diff --git a/code/monads.ml b/code/monads.ml
index 3fba1f32..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
 
@@ -968,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)
@@ -1026,6 +1035,7 @@ end = struct
     end
     include BaseT
     let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
+    let expose u = u
   end
 end;;