val (>=>) : ('a -> 'b m) -> ('b -> 'c m) -> 'a -> 'c m
val do_when : bool -> unit m -> unit m
val do_unless : bool -> unit m -> unit m
- val forever : 'a m -> 'b m
+ val forever : (unit -> 'a m) -> 'b m
val sequence : 'a m list -> 'a list m
val sequence_ : 'a m list -> unit m
end
let (>=>) f g = fun a -> f a >>= g
let do_when test u = if test then u else unit ()
let do_unless test u = if test then unit () else u
- let rec forever u = u >> forever u
+ let forever uthunk =
+ let rec loop () = uthunk () >>= fun _ -> loop ()
+ in loop ()
let sequence ms =
let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
Util.fold_right op ms (unit [])
val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
val do_when : bool -> ('x,unit) m -> ('x,unit) m
val do_unless : bool -> ('x,unit) m -> ('x,unit) m
- val forever : ('x,'a) m -> ('x,'b) m
+ val forever : (unit -> ('x,'a) m) -> ('x,'b) m
val sequence : ('x,'a) m list -> ('x,'a list) m
val sequence_ : ('x,'a) m list -> ('x,unit) m
end
let (>=>) f g = fun a -> f a >>= g
let do_when test u = if test then u else unit ()
let do_unless test u = if test then unit () else u
- let rec forever u = u >> forever u
+ let forever uthunk =
+ let rec loop () = uthunk () >>= fun _ -> loop ()
+ in loop ()
let sequence ms =
let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
Util.fold_right op ms (unit [])
val throw : err -> 'a m
val catch : 'a m -> (err -> 'a m) -> 'a m
end
+ (* ErrorT transformer when wrapped monad has plus, zero *)
+ module TP : functor (Wrapped : Monad.P) -> sig
+ include module type of T(Wrapped)
+ include Monad.PLUS with type 'a m := 'a m
+ end
module T2 : functor (Wrapped : Monad.S2) -> sig
type ('x,'a) result = ('x,'a) Wrapped.result
type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
| Success _ -> Wrapped.unit t
| Error e -> handler e)
end
+ module TP(Wrapped : Monad.P) = struct
+ module TransP = struct
+ include T(Wrapped)
+ let plus u v = Wrapped.plus u v
+ let zero () = elevate (Wrapped.zero ())
+ end
+ include TransP
+ include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
+ end
module T2(Wrapped : Monad.S2) = struct
module Trans = struct
module Wrapped = Wrapped
val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
val reset : ('a,'a) m -> ('r,'a) m
val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
- val abort : ('a,'a) m -> ('a,'b) m
+ (* val abort : ('a,'a) m -> ('a,'b) m *)
+ val abort : 'a -> ('a,'b) m
val run0 : ('a,'a) m -> 'a
end = struct
let id = fun i -> i
let callcc f = fun k -> f k k
let throw k a = fun _ -> k a
*)
- (* from http://www.haskell.org/haskellwiki/MonadCont_done_right *)
+
+ (* from http://www.haskell.org/haskellwiki/MonadCont_done_right
+ *
+ * reset :: (Monad m) => ContT a m a -> ContT r m a
+ * reset e = ContT $ \k -> runContT e return >>= k
+ *
+ * shift :: (Monad m) => ((a -> ContT r m b) -> ContT b m b) -> ContT b m a
+ * shift e = ContT $ \k ->
+ * runContT (e $ \v -> ContT $ \c -> k v >>= c) return *)
let reset u = unit ((u) id)
let shift f = (fun k -> (f (fun a -> unit (k a))) id)
- let abort a = shift (fun _ -> a)
+ (* let abort a = shift (fun _ -> a) *)
+ let abort a = shift (fun _ -> unit a)
let run0 (u : ('a,'a) m) = (u) id
end
module TC = T.T2(C);;
-print_endline "================================================";;
+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))));;
- : 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
(* (+ 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)
+ 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));;
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)))) );;
+
+
+(0, 15 = C.(run0 (let f k = k 10 >>= fun v-> unit (v+100) in reset (callcc f >>= fun v -> unit (v+5)))) );;
+