X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=blobdiff_plain;f=code%2Fmonads.ml;h=d8725937adb384bb104ce7f1781636c03f2424e3;hp=54a324831d5714ebc23782a6eae496ded167d4e4;hb=573a8b36ce653c84c2aecb2b81ef99128cb41d13;hpb=89dccec9ab1d2936b2f2ab05ec532c23863d7502

diff --git a/code/monads.ml b/code/monads.ml
index 54a32483..d8725937 100644
--- a/code/monads.ml
+++ b/code/monads.ml
@@ -38,7 +38,7 @@
  * making their implementations private. The interpreter won't let
  * let you freely interchange the `'a Reader_monad.m`s defined below
  * with `Reader_monad.env -> 'a`. The code in this library can see that
- * those are equivalent, but code outside the library can't. Instead, you'll 
+ * those are equivalent, but code outside the library can't. Instead, you'll
  * have to use operations like `run` to convert the abstract monadic types
  * to types whose internals you have free access to.
  *
@@ -55,9 +55,11 @@
  * derived from)
  *)
 
-exception Undefined
 
 (* Some library functions used below. *)
+
+exception Undefined
+
 module Util = struct
   let fold_right = List.fold_right
   let map = List.map
@@ -74,18 +76,17 @@ module Util = struct
     in loop len []
   (* Dirty hack to be a default polymorphic zero.
    * To implement this cleanly, monads without a natural zero
-   * should always wrap themselves in an option layer (see Leaf_monad). *)
+   * should always wrap themselves in an option layer (see Tree_monad). *)
   let undef = Obj.magic (fun () -> raise Undefined)
 end
 
-
-
 (*
  * This module contains factories that extend a base set of
  * monadic definitions with a larger family of standard derived values.
  *)
 
 module Monad = struct
+
   (*
    * Signature extenders:
    *   Make :: BASE -> S
@@ -114,7 +115,7 @@ module Monad = struct
      *     (Catch)   plus (unit a) v  ===  unit a
      *     (Distrib) plus u v >>= f   ===  plus (u >>= f) (v >>= f)
      * When no natural zero is available, use `let zero () = Util.undef`.
-     * The Make functor automatically detects for zero >>= ..., and 
+     * The Make functor automatically detects for zero >>= ..., and
      * plus zero _, plus _ zero; it also substitutes zero for pattern-match failures.
      *)
     val zero : unit -> ('x,'a) m
@@ -338,10 +339,9 @@ module List_monad : sig
     (* note that second argument is an 'a list, not the more abstract 'a m *)
     (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
     val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
-(* TODO
-    val permute : 'a m -> 'a m m
-    val select : 'a m -> ('a * 'a m) m
-*)
+    val permute : ('x,'a) m -> ('x,('x,'a) m) m
+    val select : ('x,'a) m -> ('x,('a * ('x,'a) m)) m
+    val expose : ('x,'a) m -> ('x,'a list) Wrapped.m
   end
 end = struct
   module Base = struct
@@ -376,7 +376,7 @@ end = struct
     | [] -> zero ()
     | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
   module T(Wrapped : Monad.S) = struct
-    (* Wrapped.sequence ms  ===  
+    (* Wrapped.sequence ms  ===
          let plus1 u v =
            Wrapped.bind u (fun x ->
            Wrapped.bind v (fun xs ->
@@ -408,20 +408,33 @@ end = struct
         Wrapped.bind v (fun vs ->
         Wrapped.unit (Base.plus us vs)))
     end)
-(*
-    let permute : 'a m -> 'a m m
-    let select : 'a m -> ('a * 'a m) m
-*)
+
+   (* insert 3 {[1;2]} ~~> {[ {[3;1;2]}; {[1;3;2]}; {[1;2;3]} ]} *)
+   let rec insert a u =
+     plus
+     (unit (Wrapped.bind u (fun us -> Wrapped.unit (a :: us))))
+     (Wrapped.bind u (fun us -> match us with
+         | [] -> zero ()
+         | x::xs -> (insert a (Wrapped.unit xs)) >>= fun v -> unit (Wrapped.bind v (fun vs -> Wrapped.unit (x :: vs)))))
+
+   (* select {[1;2;3]} ~~> {[ (1,{[2;3]}); (2,{[1;3]}), (3;{[1;2]}) ]} *)
+   let rec select u =
+     Wrapped.bind u (fun us -> match us with
+         | [] -> zero ()
+         | x::xs -> plus (unit (x, Wrapped.unit xs))
+             (select (Wrapped.unit xs) >>= fun (x', xs') -> unit (x', Wrapped.bind xs' (fun ys -> Wrapped.unit (x :: ys)))))
+
+   (* permute {[1;2;3]} ~~> {[ {[1;2;3]}; {[2;1;3]}; {[2;3;1]}; {[1;3;2]}; {[3;1;2]}; {[3;2;1]} ]} *)
+
+   let rec permute u =
+     Wrapped.bind u (fun us -> match us with
+         | [] -> unit (zero ())
+         | x::xs -> permute (Wrapped.unit xs) >>= (fun v -> insert x v))
+
+    let expose u = u
   end
 end
 
-(*
-# LL.(run(plus (unit 1) (unit 2) >>= fun i -> plus (unit i) (unit(10*i)) ));;
-- : ('_a, int) LL.result = [[1; 10; 2; 20]]
-# LL.(run(plus (unit 1) (unit 2) >>= fun i -> elevate L.(plus (unit i) (unit(10*i)) )));;
-- : ('_a, int) LL.result = [[1; 2]; [1; 20]; [10; 2]; [10; 20]]
-*)
-
 
 (* must be parameterized on (struct type err = ... end) *)
 module Error_monad(Err : sig
@@ -516,26 +529,6 @@ module Failure = Error_monad(struct
   *)
 end)
 
-(*
-# EL.(run( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
-- : int EL.result = [Failure.Error "bye"; Failure.Success 30]
-# LE.(run( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
-- : int LE.result = Failure.Error "bye"
-# EL.(run_exn( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
-Exception: Failure "bye".
-# LE.(run_exn( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
-Exception: Failure "bye".
-
-# ES.(run( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
-- : int Failure.error * S.store = (Failure.Error "bye", 1)
-# SE.(run( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
-- : (int * S.store) Failure.result = Failure.Error "bye"
-# ES.(run_exn( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
-Exception: Failure "bye".
-# SE.(run_exn( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
-Exception: Failure "bye".
- *)
-
 
 (* must be parameterized on (struct type env = ... end) *)
 module Reader_monad(Env : sig type env end) : sig
@@ -557,6 +550,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
@@ -595,6 +589,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
 
@@ -620,6 +615,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
@@ -664,9 +661,12 @@ 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
 
+
 (* State monad with different interface (structured store) *)
 module Ref_monad(V : sig
   type value
@@ -975,53 +975,17 @@ 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)
- *
  *)
 
 
-module Leaf_monad : sig
+module Tree_monad : sig
   (* We implement the type as `'a tree option` because it has a natural`plus`,
    * and the rest of the library expects that `plus` and `zero` will come together. *)
   type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
   type ('x,'a) result = 'a tree option
   type ('x,'a) result_exn = 'a tree
   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
-  (* LeafT transformer *)
+  (* TreeT transformer *)
   module T : functor (Wrapped : Monad.S) -> sig
     type ('x,'a) result = ('x,'a tree option) Wrapped.result
     type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
@@ -1030,6 +994,7 @@ module Leaf_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)
@@ -1088,212 +1053,9 @@ 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 L = List_monad;;
-module R = Reader_monad(struct type env = int -> int end);;
-module S = State_monad(struct type store = int end);;
-module T = Leaf_monad;;
-module LR = L.T(R);;
-module LS = L.T(S);;
-module TL = T.T(L);;
-module TR = T.T(R);;
-module TS = T.T(S);;
-module C = Continuation_monad
-module TC = T.T(C);;
-
-
-print_endline "=== test Leaf(...).distribute ==================";;
-
-let t1 = Some (T.Node (T.Node (T.Leaf 2, T.Leaf 3), T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11))));;
-
-let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
-TS.run ts 0;;
-(*
-- : int T.tree option * S.store =
-(Some
-  (T.Node
-    (T.Node (T.Leaf 2, T.Leaf 3),
-     T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
- 5)
-*)
-
-let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
-TS.run_exn ts2 0;;
-(*
-- : (int * S.store) T.tree option * S.store =
-(Some
-  (T.Node
-    (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
-     T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
- 5)
-*)
-
-let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
-TR.run_exn tr (fun i -> i+i);;
-(*
-- : int T.tree option =
-Some
- (T.Node
-   (T.Node (T.Leaf 4, T.Leaf 6),
-    T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
-*)
-
-let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
-TL.run_exn tl;;
-(*
-- : (int * int) TL.result =
-[Some
-  (T.Node
-    (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
-     T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
-*)
-
-let l2 = [1;2;3;4;5];;
-let t2 = Some (T.Node (T.Leaf 1, (T.Node (T.Node (T.Node (T.Leaf 2, T.Leaf 3), T.Leaf 4), T.Leaf 5))));;
-
-LR.(run (distribute (fun i -> R.(asks (fun e -> e i))) l2 >>= fun j -> LR.(plus (unit j) (unit (succ j))))) (fun i -> i*10);;
-(* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
-
-TR.(run_exn (distribute (fun i -> R.(asks (fun e -> e i))) t2 >>= fun j -> TR.(plus (unit j) (unit (succ j))))) (fun i -> i*10);;
-(*
-int T.tree option =
-Some
- (T.Node
-   (T.Node (T.Leaf 10, T.Leaf 11),
-    T.Node
-     (T.Node
-       (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
-        T.Node (T.Leaf 40, T.Leaf 41)),
-      T.Node (T.Leaf 50, T.Leaf 51))))
- *)
-
-LS.run (LS.distribute (fun i -> if i = -1 then S.get else if i < 0 then S.(puts succ >> unit 0) else S.unit i) [10;-1;-2;-1;20]) 0;;
-(*
-- : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
-*)
-
-print_endline "=== test Leaf(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);;
-
-let testc df ic =
-    C.run_exn TC.(run (distribute df t1)) ic;;
-
-
-(*
-(* do nothing *)
-let initial_continuation = fun t -> t in
-TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
-*)
-testc (C.unit) id;;
-
-(*
-(* count leaves, using continuation *)
-let initial_continuation = fun t -> 0 in
-TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
-*)
-
-testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
-
-(*
-(* convert tree to list of leaves *)
-let initial_continuation = fun t -> [] in
-TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
-*)
-
-testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
-
-(*
-(* square each leaf using continuation *)
-let initial_continuation = fun t -> t in
-TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
-*)
-
-testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
-
-
-(*
-(* replace leaves with list, using continuation *)
-let initial_continuation = fun t -> t in
-TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
-*)
-
-testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;
-
-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)))) );;
 
+end;;
 
-(0, 15 = C.(run0 (let f k = k 10 >>= fun v-> unit (v+100) in reset (callcc f >>= fun v -> unit (v+5)))) );;