4 * Relies on features introduced in OCaml 3.12
6 * This library uses parameterized modules, see tree_monadize.ml for
7 * more examples and explanation.
9 * Some comparisons with the Haskell monadic libraries, which we mostly follow:
10 * In Haskell, the Reader 'a monadic type would be defined something like this:
11 * newtype Reader a = Reader { runReader :: env -> a }
12 * (For simplicity, I'm suppressing the fact that Reader is also parameterized
13 * on the type of env.)
14 * This creates a type wrapper around `env -> a`, so that Haskell will
15 * distinguish between values that have been specifically designated as
16 * being of type `Reader a`, and common-garden values of type `env -> a`.
17 * To lift an aribtrary expression E of type `env -> a` into an `Reader a`,
19 * Reader { runReader = E }
20 * or use any of the following equivalent shorthands:
23 * To drop an expression R of type `Reader a` back into an `env -> a`, you do
27 * The `newtype` in the type declaration ensures that Haskell does this all
28 * efficiently: though it regards E and R as type-distinct, their underlying
29 * machine implementation is identical and doesn't need to be transformed when
30 * lifting/dropping from one type to the other.
32 * Now, you _could_ also declare monads as record types in OCaml, too, _but_
33 * doing so would introduce an extra level of machine representation, and
34 * lifting/dropping from the one type to the other wouldn't be free like it is
37 * This library encapsulates the monadic types in another way: by
38 * making their implementations private. The interpreter won't let
39 * let you freely interchange the `'a Reader_monad.m`s defined below
40 * with `Reader_monad.env -> 'a`. The code in this library can see that
41 * those are equivalent, but code outside the library can't. Instead, you'll
42 * have to use operations like `run` to convert the abstract monadic types
43 * to types whose internals you have free access to.
45 * Acknowledgements: This is largely based on the mtl library distributed
46 * with the Glasgow Haskell Compiler. I've also been helped in
47 * various ways by posts and direct feedback from Oleg Kiselyov and
48 * Chung-chieh Shan. The following were also useful:
49 * - <http://pauillac.inria.fr/~xleroy/mpri/progfunc/>
50 * - Ken Shan "Monads for natural language semantics" <http://arxiv.org/abs/cs/0205026v1>
51 * - http://www.grabmueller.de/martin/www/pub/Transformers.pdf
52 * - http://en.wikibooks.org/wiki/Haskell/Monad_transformers
54 * Licensing: MIT (if that's compatible with the ghc sources this is partly
60 (* Some library functions used below. *)
62 let fold_right = List.fold_right
64 let append = List.append
65 let reverse = List.rev
66 let concat = List.concat
67 let concat_map f lst = List.concat (List.map f lst)
68 (* let zip = List.combine *)
69 let unzip = List.split
70 let zip_with = List.map2
71 let replicate len fill =
73 if n == 0 then accu else loop (pred n) (fill :: accu)
75 (* Dirty hack to be a default polymorphic zero.
76 * To implement this cleanly, monads without a natural zero
77 * should always wrap themselves in an option layer (see Leaf_monad). *)
78 let undef = Obj.magic (fun () -> raise Undefined)
84 * This module contains factories that extend a base set of
85 * monadic definitions with a larger family of standard derived values.
90 * Signature extenders:
92 * MakeT :: BASET (with Wrapped : S) -> result sig not declared
96 (* type of base definitions *)
97 module type BASE = sig
98 (* We make all monadic types doubly-parameterized so that they
99 * can layer nicely with Continuation, which needs the second
103 type ('x,'a) result_exn
104 val unit : 'a -> ('x,'a) m
105 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
106 val run : ('x,'a) m -> ('x,'a) result
107 (* run_exn tries to provide a more ground-level result, but may fail *)
108 val run_exn : ('x,'a) m -> ('x,'a) result_exn
109 (* To simplify the library, we require every monad to supply a plus and zero. These obey the following laws:
110 * zero >>= f === zero
113 * Additionally, they will obey one of the following laws:
114 * (Catch) plus (unit a) v === unit a
115 * (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
116 * When no natural zero is available, use `let zero () = Util.undef`.
117 * The Make functor automatically detects for zero >>= ..., and
118 * plus zero _, plus _ zero; it also substitutes zero for pattern-match failures.
120 val zero : unit -> ('x,'a) m
121 (* zero has to be thunked to ensure results are always poly enough *)
122 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
126 val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
127 val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
128 val join : ('x,('x,'a) m) m -> ('x,'a) m
129 val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
130 val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
131 val lift2 : ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
132 val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
133 val do_when : bool -> ('x,unit) m -> ('x,unit) m
134 val do_unless : bool -> ('x,unit) m -> ('x,unit) m
135 val forever : (unit -> ('x,'a) m) -> ('x,'b) m
136 val sequence : ('x,'a) m list -> ('x,'a list) m
137 val sequence_ : ('x,'a) m list -> ('x,unit) m
138 val guard : bool -> ('x,unit) m
139 val sum : ('x,'a) m list -> ('x,'a) m
142 module Make(B : BASE) : S with type ('x,'a) m = ('x,'a) B.m and type ('x,'a) result = ('x,'a) B.result and type ('x,'a) result_exn = ('x,'a) B.result_exn = struct
144 let bind (u : ('x,'a) m) (f : 'a -> ('x,'b) m) : ('x,'b) m =
145 if u == Util.undef then Util.undef
146 else B.bind u (fun a -> try f a with Match_failure _ -> zero ())
148 if u == Util.undef then v else if v == Util.undef then u else B.plus u v
150 if u == Util.undef then raise Undefined else B.run u
152 if u == Util.undef then raise Undefined else B.run_exn u
154 (* expressions after >> will be evaluated before they're passed to
155 * bind, so you can't do `zero () >> assert false`
156 * this works though: `zero () >>= fun _ -> assert false`
158 let (>>) u v = u >>= fun _ -> v
159 let lift f u = u >>= fun a -> unit (f a)
160 (* lift is called listM, fmap, and <$> in Haskell *)
161 let join uu = uu >>= fun u -> u
162 (* u >>= f === join (lift f u) *)
163 let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
164 (* [f] <*> [x1,x2] = [f x1,f x2] *)
165 (* let apply u v = u >>= fun f -> lift f v *)
166 (* let apply = lift2 id *)
167 let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
168 (* let lift f u === apply (unit f) u *)
169 (* let lift2 f u v = apply (lift f u) v *)
170 let (>=>) f g = fun a -> f a >>= g
171 let do_when test u = if test then u else unit ()
172 let do_unless test u = if test then unit () else u
173 (* A Haskell-like version works:
174 let rec forever uthunk = uthunk () >>= fun _ -> forever uthunk
175 * but the recursive call is not in tail position so this can stack overflow. *)
178 let id result = result in
179 let kcell = ref id in
181 let result = uthunk (kcell := id) >>= chained
184 kcell := loop; z (* we use z only for its polymorphism *)
186 (* Reimplementations of the preceding using a hand-rolled State or StateT
187 can also stack overflow. *)
189 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
190 Util.fold_right op ms (unit [])
192 Util.fold_right (>>) ms (unit ())
194 (* Haskell defines these other operations combining lists and monads.
195 * We don't, but notice that M.mapM == ListT(M).distribute
196 * There's also a parallel TreeT(M).distribute *)
198 let mapM f alist = sequence (Util.map f alist)
199 let mapM_ f alist = sequence_ (Util.map f alist)
200 let rec filterM f lst = match lst with
202 | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
203 let forM alist f = mapM f alist
204 let forM_ alist f = mapM_ f alist
205 let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
206 let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
207 let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
208 let rec foldM f z lst = match lst with
210 | x::xs -> f z x >>= fun z' -> foldM f z' xs
211 let foldM_ f z xs = foldM f z xs >> unit ()
212 let replicateM n x = sequence (Util.replicate n x)
213 let replicateM_ n x = sequence_ (Util.replicate n x)
215 let guard test = if test then B.unit () else zero ()
216 let sum ms = Util.fold_right plus ms (zero ())
219 (* Signatures for MonadT *)
220 module type BASET = sig
224 type ('x,'a) result_exn
225 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
226 val run : ('x,'a) m -> ('x,'a) result
227 val run_exn : ('x,'a) m -> ('x,'a) result_exn
228 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
229 (* lift/elevate laws:
230 * elevate (W.unit a) == unit a
231 * elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
233 val zero : unit -> ('x,'a) m
234 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
236 module MakeT(T : BASET) = struct
239 let unit a = elevate (Wrapped.unit a)
241 let elevate = T.elevate
250 module Identity_monad : sig
251 (* expose only the implementation of type `'a result` *)
252 type ('x,'a) result = 'a
253 type ('x,'a) result_exn = 'a
254 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
258 type ('x,'a) result = 'a
259 type ('x,'a) result_exn = 'a
264 let zero () = Util.undef
267 include Monad.Make(Base)
271 module Maybe_monad : sig
272 (* expose only the implementation of type `'a result` *)
273 type ('x,'a) result = 'a option
274 type ('x,'a) result_exn = 'a
275 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
276 (* MaybeT transformer *)
277 module T : functor (Wrapped : Monad.S) -> sig
278 type ('x,'a) result = ('x,'a option) Wrapped.result
279 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
280 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
281 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
285 type ('x,'a) m = 'a option
286 type ('x,'a) result = 'a option
287 type ('x,'a) result_exn = 'a
289 let bind u f = match u with Some a -> f a | None -> None
291 let run_exn u = match u with
293 | None -> failwith "no value"
295 (* satisfies Catch *)
296 let plus u v = match u with None -> v | _ -> u
298 include Monad.Make(Base)
299 module T(Wrapped : Monad.S) = struct
300 module BaseT = struct
301 include Monad.MakeT(struct
302 module Wrapped = Wrapped
303 type ('x,'a) m = ('x,'a option) Wrapped.m
304 type ('x,'a) result = ('x,'a option) Wrapped.result
305 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
306 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
307 let bind u f = Wrapped.bind u (fun t -> match t with
309 | None -> Wrapped.unit None)
310 let run u = Wrapped.run u
312 let w = Wrapped.bind u (fun t -> match t with
313 | Some a -> Wrapped.unit a
314 | None -> Wrapped.zero ()
315 ) in Wrapped.run_exn w
316 let zero () = Wrapped.unit None
317 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
325 module List_monad : sig
326 (* declare additional operation, while still hiding implementation of type m *)
327 type ('x,'a) result = 'a list
328 type ('x,'a) result_exn = 'a
329 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
330 val permute : ('x,'a) m -> ('x,('x,'a) m) m
331 val select : ('x,'a) m -> ('x,'a * ('x,'a) m) m
332 (* ListT transformer *)
333 module T : functor (Wrapped : Monad.S) -> sig
334 type ('x,'a) result = ('x,'a list) Wrapped.result
335 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
336 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
337 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
338 (* note that second argument is an 'a list, not the more abstract 'a m *)
339 (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
340 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
342 val permute : 'a m -> 'a m m
343 val select : 'a m -> ('a * 'a m) m
348 type ('x,'a) m = 'a list
349 type ('x,'a) result = 'a list
350 type ('x,'a) result_exn = 'a
352 let bind u f = Util.concat_map f u
354 let run_exn u = match u with
355 | [] -> failwith "no values"
357 | many -> failwith "multiple values"
359 (* satisfies Distrib *)
360 let plus = Util.append
362 include Monad.Make(Base)
363 (* let either u v = plus u v *)
364 (* insert 3 [1;2] ~~> [[3;1;2]; [1;3;2]; [1;2;3]] *)
366 plus (unit (a :: u)) (match u with
368 | x :: xs -> (insert a xs) >>= fun v -> unit (x :: v)
370 (* permute [1;2;3] ~~> [1;2;3]; [2;1;3]; [2;3;1]; [1;3;2]; [3;1;2]; [3;2;1] *)
371 let rec permute u = match u with
373 | x :: xs -> (permute xs) >>= (fun v -> insert x v)
374 (* select [1;2;3] ~~> [(1,[2;3]); (2,[1;3]), (3;[1;2])] *)
375 let rec select u = match u with
377 | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
378 module T(Wrapped : Monad.S) = struct
379 (* Wrapped.sequence ms ===
381 Wrapped.bind u (fun x ->
382 Wrapped.bind v (fun xs ->
383 Wrapped.unit (x :: xs)))
384 in Util.fold_right plus1 ms (Wrapped.unit []) *)
385 (* distribute === Wrapped.mapM; copies alist to its image under f *)
386 let distribute f alist = Wrapped.sequence (Util.map f alist)
388 include Monad.MakeT(struct
389 module Wrapped = Wrapped
390 type ('x,'a) m = ('x,'a list) Wrapped.m
391 type ('x,'a) result = ('x,'a list) Wrapped.result
392 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
393 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
395 Wrapped.bind u (fun ts ->
396 Wrapped.bind (distribute f ts) (fun tts ->
397 Wrapped.unit (Util.concat tts)))
398 let run u = Wrapped.run u
400 let w = Wrapped.bind u (fun ts -> match ts with
401 | [] -> Wrapped.zero ()
402 | [a] -> Wrapped.unit a
403 | many -> Wrapped.zero ()
404 ) in Wrapped.run_exn w
405 let zero () = Wrapped.unit []
407 Wrapped.bind u (fun us ->
408 Wrapped.bind v (fun vs ->
409 Wrapped.unit (Base.plus us vs)))
412 let permute : 'a m -> 'a m m
413 let select : 'a m -> ('a * 'a m) m
419 # LL.(run(plus (unit 1) (unit 2) >>= fun i -> plus (unit i) (unit(10*i)) ));;
420 - : ('_a, int) LL.result = [[1; 10; 2; 20]]
421 # LL.(run(plus (unit 1) (unit 2) >>= fun i -> elevate L.(plus (unit i) (unit(10*i)) )));;
422 - : ('_a, int) LL.result = [[1; 2]; [1; 20]; [10; 2]; [10; 20]]
426 (* must be parameterized on (struct type err = ... end) *)
427 module Error_monad(Err : sig
431 val zero : unit -> err
432 val plus : err -> err -> err
435 (* declare additional operations, while still hiding implementation of type m *)
437 type 'a error = Error of err | Success of 'a
438 type ('x,'a) result = 'a error
439 type ('x,'a) result_exn = 'a
440 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
441 val throw : err -> ('x,'a) m
442 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
443 (* ErrorT transformer *)
444 module T : functor (Wrapped : Monad.S) -> sig
445 type ('x,'a) result = ('x,'a) Wrapped.result
446 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
447 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
448 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
449 val throw : err -> ('x,'a) m
450 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
454 type 'a error = Error of err | Success of 'a
456 type ('x,'a) m = 'a error
457 type ('x,'a) result = 'a error
458 type ('x,'a) result_exn = 'a
459 let unit a = Success a
460 let bind u f = match u with
462 | Error e -> Error e (* input and output may be of different 'a types *)
464 let run_exn u = match u with
466 | Error e -> raise (Err.Exc e)
467 let zero () = Util.undef
468 (* satisfies Catch *)
469 let plus u v = match u with
471 | Error _ -> if v == Util.undef then u else v
473 include Monad.Make(Base)
474 (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
475 let throw e = Error e
476 let catch u handler = match u with
478 | Error e -> handler e
479 module T(Wrapped : Monad.S) = struct
480 include Monad.MakeT(struct
481 module Wrapped = Wrapped
482 type ('x,'a) m = ('x,'a error) Wrapped.m
483 type ('x,'a) result = ('x,'a) Wrapped.result
484 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
485 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
486 let bind u f = Wrapped.bind u (fun t -> match t with
488 | Error e -> Wrapped.unit (Error e))
490 let w = Wrapped.bind u (fun t -> match t with
491 | Success a -> Wrapped.unit a
492 | Error e -> Wrapped.zero ()
495 let w = Wrapped.bind u (fun t -> match t with
496 | Success a -> Wrapped.unit a
497 | Error e -> raise (Err.Exc e))
499 let plus u v = Wrapped.plus u v
500 let zero () = Wrapped.zero () (* elevate (Wrapped.zero ()) *)
502 let throw e = Wrapped.unit (Error e)
503 let catch u handler = Wrapped.bind u (fun t -> match t with
504 | Success _ -> Wrapped.unit t
505 | Error e -> handler e)
509 (* pre-define common instance of Error_monad *)
510 module Failure = Error_monad(struct
512 exception Exc = Failure
515 let plus s1 s2 = s1 ^ "\n" ^ s2
520 # EL.(run( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
521 - : int EL.result = [Failure.Error "bye"; Failure.Success 30]
522 # LE.(run( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
523 - : int LE.result = Failure.Error "bye"
524 # EL.(run_exn( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
525 Exception: Failure "bye".
526 # LE.(run_exn( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
527 Exception: Failure "bye".
529 # ES.(run( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
530 - : int Failure.error * S.store = (Failure.Error "bye", 1)
531 # SE.(run( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
532 - : (int * S.store) Failure.result = Failure.Error "bye"
533 # ES.(run_exn( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
534 Exception: Failure "bye".
535 # SE.(run_exn( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
536 Exception: Failure "bye".
540 (* must be parameterized on (struct type env = ... end) *)
541 module Reader_monad(Env : sig type env end) : sig
542 (* declare additional operations, while still hiding implementation of type m *)
544 type ('x,'a) result = env -> 'a
545 type ('x,'a) result_exn = env -> 'a
546 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
548 val asks : (env -> 'a) -> ('x,'a) m
549 (* lookup i == `fun e -> e i` would assume env is a functional type *)
550 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
551 (* ReaderT transformer *)
552 module T : functor (Wrapped : Monad.S) -> sig
553 type ('x,'a) result = env -> ('x,'a) Wrapped.result
554 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
555 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
556 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
558 val asks : (env -> 'a) -> ('x,'a) m
559 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
564 type ('x,'a) m = env -> 'a
565 type ('x,'a) result = env -> 'a
566 type ('x,'a) result_exn = env -> 'a
567 let unit a = fun e -> a
568 let bind u f = fun e -> let a = u e in let u' = f a in u' e
569 let run u = fun e -> u e
571 let zero () = Util.undef
574 include Monad.Make(Base)
576 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
577 let local modifier u = fun e -> u (modifier e)
578 module T(Wrapped : Monad.S) = struct
579 module BaseT = struct
580 module Wrapped = Wrapped
581 type ('x,'a) m = env -> ('x,'a) Wrapped.m
582 type ('x,'a) result = env -> ('x,'a) Wrapped.result
583 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
584 let elevate w = fun e -> w
585 let bind u f = fun e -> Wrapped.bind (u e) (fun a -> f a e)
586 let run u = fun e -> Wrapped.run (u e)
587 let run_exn u = fun e -> Wrapped.run_exn (u e)
588 (* satisfies Distrib *)
589 let plus u v = fun e -> Wrapped.plus (u e) (v e)
590 let zero () = fun e -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
592 include Monad.MakeT(BaseT)
593 let ask = Wrapped.unit
594 let local modifier u = fun e -> u (modifier e)
595 let asks selector = ask >>= (fun e ->
596 try unit (selector e)
597 with Not_found -> fun e -> Wrapped.zero ())
602 (* must be parameterized on (struct type store = ... end) *)
603 module State_monad(Store : sig type store end) : sig
604 (* declare additional operations, while still hiding implementation of type m *)
605 type store = Store.store
606 type ('x,'a) result = store -> 'a * store
607 type ('x,'a) result_exn = store -> 'a
608 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
609 val get : ('x,store) m
610 val gets : (store -> 'a) -> ('x,'a) m
611 val put : store -> ('x,unit) m
612 val puts : (store -> store) -> ('x,unit) m
613 (* StateT transformer *)
614 module T : functor (Wrapped : Monad.S) -> sig
615 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
616 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
617 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
618 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
619 val get : ('x,store) m
620 val gets : (store -> 'a) -> ('x,'a) m
621 val put : store -> ('x,unit) m
622 val puts : (store -> store) -> ('x,unit) m
625 type store = Store.store
627 type ('x,'a) m = store -> 'a * store
628 type ('x,'a) result = store -> 'a * store
629 type ('x,'a) result_exn = store -> 'a
630 let unit a = fun s -> (a, s)
631 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
632 let run u = fun s -> (u s)
633 let run_exn u = fun s -> fst (u s)
634 let zero () = Util.undef
637 include Monad.Make(Base)
638 let get = fun s -> (s, s)
639 let gets viewer = fun s -> (viewer s, s) (* may fail *)
640 let put s = fun _ -> ((), s)
641 let puts modifier = fun s -> ((), modifier s)
642 module T(Wrapped : Monad.S) = struct
643 module BaseT = struct
644 module Wrapped = Wrapped
645 type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
646 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
647 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
648 let elevate w = fun s ->
649 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
650 let bind u f = fun s ->
651 Wrapped.bind (u s) (fun (a, s') -> f a s')
652 let run u = fun s -> Wrapped.run (u s)
653 let run_exn u = fun s ->
654 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
656 (* satisfies Distrib *)
657 let plus u v = fun s -> Wrapped.plus (u s) (v s)
658 let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
660 include Monad.MakeT(BaseT)
661 let get = fun s -> Wrapped.unit (s, s)
662 let gets viewer = fun s ->
663 try Wrapped.unit (viewer s, s)
664 with Not_found -> Wrapped.zero ()
665 let put s = fun _ -> Wrapped.unit ((), s)
666 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
670 (* State monad with different interface (structured store) *)
671 module Ref_monad(V : sig
676 type ('x,'a) result = 'a
677 type ('x,'a) result_exn = 'a
678 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
679 val newref : value -> ('x,ref) m
680 val deref : ref -> ('x,value) m
681 val change : ref -> value -> ('x,unit) m
682 (* RefT transformer *)
683 module T : functor (Wrapped : Monad.S) -> sig
684 type ('x,'a) result = ('x,'a) Wrapped.result
685 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
686 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
687 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
688 val newref : value -> ('x,ref) m
689 val deref : ref -> ('x,value) m
690 val change : ref -> value -> ('x,unit) m
695 module D = Map.Make(struct type t = ref let compare = compare end)
696 type dict = { next: ref; tree : value D.t }
697 let empty = { next = 0; tree = D.empty }
698 let alloc (value : value) (d : dict) =
699 (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
700 let read (key : ref) (d : dict) =
702 let write (key : ref) (value : value) (d : dict) =
703 { next = d.next; tree = D.add key value d.tree }
705 type ('x,'a) m = dict -> 'a * dict
706 type ('x,'a) result = 'a
707 type ('x,'a) result_exn = 'a
708 let unit a = fun s -> (a, s)
709 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
710 let run u = fst (u empty)
712 let zero () = Util.undef
715 include Monad.Make(Base)
716 let newref value = fun s -> alloc value s
717 let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
718 let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
719 module T(Wrapped : Monad.S) = struct
720 module BaseT = struct
721 module Wrapped = Wrapped
722 type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
723 type ('x,'a) result = ('x,'a) Wrapped.result
724 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
725 let elevate w = fun s ->
726 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
727 let bind u f = fun s ->
728 Wrapped.bind (u s) (fun (a, s') -> f a s')
730 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
733 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
735 (* satisfies Distrib *)
736 let plus u v = fun s -> Wrapped.plus (u s) (v s)
737 let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
739 include Monad.MakeT(BaseT)
740 let newref value = fun s -> Wrapped.unit (alloc value s)
741 let deref key = fun s -> Wrapped.unit (read key s, s)
742 let change key value = fun s -> Wrapped.unit ((), write key value s)
747 (* must be parameterized on (struct type log = ... end) *)
748 module Writer_monad(Log : sig
751 val plus : log -> log -> log
753 (* declare additional operations, while still hiding implementation of type m *)
755 type ('x,'a) result = 'a * log
756 type ('x,'a) result_exn = 'a * log
757 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
758 val tell : log -> ('x,unit) m
759 val listen : ('x,'a) m -> ('x,'a * log) m
760 val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
761 (* val pass : ('x,'a * (log -> log)) m -> ('x,'a) m *)
762 val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
763 (* WriterT transformer *)
764 module T : functor (Wrapped : Monad.S) -> sig
765 type ('x,'a) result = ('x,'a * log) Wrapped.result
766 type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
767 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
768 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
769 val tell : log -> ('x,unit) m
770 val listen : ('x,'a) m -> ('x,'a * log) m
771 val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
772 val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
777 type ('x,'a) m = 'a * log
778 type ('x,'a) result = 'a * log
779 type ('x,'a) result_exn = 'a * log
780 let unit a = (a, Log.zero)
781 let bind (a, w) f = let (b, w') = f a in (b, Log.plus w w')
784 let zero () = Util.undef
787 include Monad.Make(Base)
788 let tell entries = ((), entries) (* add entries to log *)
789 let listen (a, w) = ((a, w), w)
790 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
791 let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
792 let censor f u = pass (u >>= fun a -> unit (a, f))
793 module T(Wrapped : Monad.S) = struct
794 module BaseT = struct
795 module Wrapped = Wrapped
796 type ('x,'a) m = ('x,'a * log) Wrapped.m
797 type ('x,'a) result = ('x,'a * log) Wrapped.result
798 type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
800 Wrapped.bind w (fun a -> Wrapped.unit (a, Log.zero))
802 Wrapped.bind u (fun (a, w) ->
803 Wrapped.bind (f a) (fun (b, w') ->
804 Wrapped.unit (b, Log.plus w w')))
805 let zero () = elevate (Wrapped.zero ())
806 let plus u v = Wrapped.plus u v
807 let run u = Wrapped.run u
808 let run_exn u = Wrapped.run_exn u
810 include Monad.MakeT(BaseT)
811 let tell entries = Wrapped.unit ((), entries)
812 let listen u = Wrapped.bind u (fun (a, w) -> Wrapped.unit ((a, w), w))
813 let pass u = Wrapped.bind u (fun ((a, f), w) -> Wrapped.unit (a, f w))
814 (* rest are derived in same way as before *)
815 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w)
816 let censor f u = pass (u >>= fun a -> unit (a, f))
820 (* pre-define simple Writer *)
821 module Writer1 = Writer_monad(struct
824 let plus s1 s2 = s1 ^ "\n" ^ s2
827 (* slightly more efficient Writer *)
828 module Writer2 = struct
829 include Writer_monad(struct
830 type log = string list
832 let plus w w' = Util.append w' w
834 let tell_string s = tell [s]
835 let tell entries = tell (Util.reverse entries)
836 let run u = let (a, w) = run u in (a, Util.reverse w)
842 module IO_monad : sig
843 (* declare additional operation, while still hiding implementation of type m *)
844 type ('x,'a) result = 'a
845 type ('x,'a) result_exn = 'a
846 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
847 val printf : ('a, unit, string, ('x,unit) m) format4 -> 'a
848 val print_string : string -> ('x,unit) m
849 val print_int : int -> ('x,unit) m
850 val print_hex : int -> ('x,unit) m
851 val print_bool : bool -> ('x,unit) m
854 type ('x,'a) m = { run : unit -> unit; value : 'a }
855 type ('x,'a) result = 'a
856 type ('x,'a) result_exn = 'a
857 let unit a = { run = (fun () -> ()); value = a }
858 let bind (a : ('x,'a) m) (f: 'a -> ('x,'b) m) : ('x,'b) m =
859 let fres = f a.value in
860 { run = (fun () -> a.run (); fres.run ()); value = fres.value }
861 let run a = let () = a.run () in a.value
863 let zero () = Util.undef
866 include Monad.Make(Base)
868 Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
869 let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
870 let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
871 let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
872 let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
876 module Continuation_monad : sig
877 (* expose only the implementation of type `('r,'a) result` *)
879 type ('r,'a) result = ('r,'a) m
880 type ('r,'a) result_exn = ('a -> 'r) -> 'r
881 include Monad.S with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn and type ('r,'a) m := ('r,'a) m
882 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
883 val reset : ('a,'a) m -> ('r,'a) m
884 val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
885 (* val abort : ('a,'a) m -> ('a,'b) m *)
886 val abort : 'a -> ('a,'b) m
887 val run0 : ('a,'a) m -> 'a
888 (* ContinuationT transformer *)
889 module T : functor (Wrapped : Monad.S) -> sig
891 type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
892 type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
893 include Monad.S with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn and type ('r,'a) m := ('r,'a) m
894 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
895 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
896 (* TODO: reset,shift,abort,run0 *)
901 (* 'r is result type of whole computation *)
902 type ('r,'a) m = ('a -> 'r) -> 'r
903 type ('r,'a) result = ('a -> 'r) -> 'r
904 type ('r,'a) result_exn = ('r,'a) result
905 let unit a = (fun k -> k a)
906 let bind u f = (fun k -> (u) (fun a -> (f a) k))
909 let zero () = Util.undef
912 include Monad.Make(Base)
913 let callcc f = (fun k ->
914 let usek a = (fun _ -> k a)
917 val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
918 val throw : ('a -> 'r) -> 'a -> ('r,'b) m
919 let callcc f = fun k -> f k k
920 let throw k a = fun _ -> k a
923 (* from http://www.haskell.org/haskellwiki/MonadCont_done_right
925 * reset :: (Monad m) => ContT a m a -> ContT r m a
926 * reset e = ContT $ \k -> runContT e return >>= k
928 * shift :: (Monad m) => ((a -> ContT r m b) -> ContT b m b) -> ContT b m a
929 * shift e = ContT $ \k ->
930 * runContT (e $ \v -> ContT $ \c -> k v >>= c) return *)
931 let reset u = unit ((u) id)
932 let shift f = (fun k -> (f (fun a -> unit (k a))) id)
933 (* let abort a = shift (fun _ -> a) *)
934 let abort a = shift (fun _ -> unit a)
935 let run0 (u : ('a,'a) m) = (u) id
936 module T(Wrapped : Monad.S) = struct
937 module BaseT = struct
938 module Wrapped = Wrapped
939 type ('r,'a) m = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.m
940 type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
941 type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
942 let elevate w = fun k -> Wrapped.bind w k
943 let bind u f = fun k -> u (fun a -> f a k)
944 let run u k = Wrapped.run (u k)
945 let run_exn u k = Wrapped.run_exn (u k)
946 let zero () = Util.undef
949 include Monad.MakeT(BaseT)
950 let callcc f = (fun k ->
951 let usek a = (fun _ -> k a)
959 * (define (example n)
960 * (let ([u (let/cc k ; type int -> int pair
961 * (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
962 * (+ 1 (car v))))]) ; int
963 * (cons u 0))) ; int pair
964 * ; (example 10) ~~> '(111 . 0)
965 * ; (example -10) ~~> '(0 . 0)
968 * let example n : (int * int) =
969 * Continuation_monad.(let u = callcc (fun k ->
970 * (if n < 0 then k 0 else unit [n + 100])
971 * (* all of the following is skipped by k 0; the end type int is k's input type *)
972 * >>= fun [x] -> unit (x + 1)
974 * (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
975 * >>= fun x -> unit (x, 0)
979 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
980 * let example1 () : int =
981 * Continuation_monad.(let v = reset (
982 * let u = shift (fun k -> unit (10 + 1))
983 * in u >>= fun x -> unit (100 + x)
984 * ) in let w = v >>= fun x -> unit (1000 + x)
987 * (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
989 * Continuation_monad.(let v = reset (
990 * let u = shift (fun k -> k (10 :: [1]))
991 * in u >>= fun x -> unit (100 :: x)
992 * ) in let w = v >>= fun x -> unit (1000 :: x)
995 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
997 * Continuation_monad.(let v = reset (
998 * let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
999 * in u >>= fun x -> unit (100 :: x)
1000 * ) in let w = v >>= fun x -> unit (1000 :: x)
1003 * (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1004 * (* not sure if this example can be typed without a sum-type *)
1006 * (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1007 * let example5 () : int =
1008 * Continuation_monad.(let v = reset (
1009 * let u = shift (fun k -> k 1 >>= fun x -> k x)
1010 * in u >>= fun x -> unit (10 + x)
1011 * ) in let w = v >>= fun x -> unit (100 + x)
1017 module Leaf_monad : sig
1018 (* We implement the type as `'a tree option` because it has a natural`plus`,
1019 * and the rest of the library expects that `plus` and `zero` will come together. *)
1020 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1021 type ('x,'a) result = 'a tree option
1022 type ('x,'a) result_exn = 'a tree
1023 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1024 (* LeafT transformer *)
1025 module T : functor (Wrapped : Monad.S) -> sig
1026 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1027 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1028 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1029 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
1030 (* note that second argument is an 'a tree?, not the more abstract 'a m *)
1031 (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
1032 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
1035 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1036 (* uses supplied plus and zero to copy t to its image under f *)
1037 let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
1039 | Some ts -> let rec loop ts = (match ts with
1042 (* recursive application of f may delete a branch *)
1043 plus (loop l) (loop r)
1045 module Base = struct
1046 type ('x,'a) m = 'a tree option
1047 type ('x,'a) result = 'a tree option
1048 type ('x,'a) result_exn = 'a tree
1049 let unit a = Some (Leaf a)
1051 (* satisfies Distrib *)
1052 let plus u v = match (u, v) with
1055 | Some us, Some vs -> Some (Node (us, vs))
1056 let bind u f = mapT f u zero plus
1058 let run_exn u = match u with
1059 | None -> failwith "no values"
1061 | Some (Leaf a) -> a
1062 | many -> failwith "multiple values"
1066 include Monad.Make(Base)
1067 module T(Wrapped : Monad.S) = struct
1068 module BaseT = struct
1069 include Monad.MakeT(struct
1070 module Wrapped = Wrapped
1071 type ('x,'a) m = ('x,'a tree option) Wrapped.m
1072 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1073 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1074 let zero () = Wrapped.unit None
1076 Wrapped.bind u (fun us ->
1077 Wrapped.bind v (fun vs ->
1078 Wrapped.unit (Base.plus us vs)))
1079 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1080 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1081 let run u = Wrapped.run u
1083 let w = Wrapped.bind u (fun t -> match t with
1084 | None -> Wrapped.zero ()
1085 | Some ts -> Wrapped.unit ts
1086 ) in Wrapped.run_exn w
1090 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1095 module L = List_monad;;
1096 module R = Reader_monad(struct type env = int -> int end);;
1097 module S = State_monad(struct type store = int end);;
1098 module T = Leaf_monad;;
1099 module LR = L.T(R);;
1100 module LS = L.T(S);;
1101 module TL = T.T(L);;
1102 module TR = T.T(R);;
1103 module TS = T.T(S);;
1104 module C = Continuation_monad
1105 module TC = T.T(C);;
1108 print_endline "=== test Leaf(...).distribute ==================";;
1110 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))));;
1112 let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
1115 - : int T.tree option * S.store =
1118 (T.Node (T.Leaf 2, T.Leaf 3),
1119 T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
1123 let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
1126 - : (int * S.store) T.tree option * S.store =
1129 (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
1130 T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
1134 let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
1135 TR.run_exn tr (fun i -> i+i);;
1137 - : int T.tree option =
1140 (T.Node (T.Leaf 4, T.Leaf 6),
1141 T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
1144 let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
1147 - : (int * int) TL.result =
1150 (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
1151 T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
1154 let l2 = [1;2;3;4;5];;
1155 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))));;
1157 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);;
1158 (* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
1160 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);;
1165 (T.Node (T.Leaf 10, T.Leaf 11),
1168 (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
1169 T.Node (T.Leaf 40, T.Leaf 41)),
1170 T.Node (T.Leaf 50, T.Leaf 51))))
1173 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;;
1175 - : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
1178 print_endline "=== test Leaf(Continuation).distribute ==================";;
1180 let id : 'z. 'z -> 'z = fun x -> x
1182 let example n : (int * int) =
1183 Continuation_monad.(let u = callcc (fun k ->
1184 (if n < 0 then k 0 else unit [n + 100])
1185 (* all of the following is skipped by k 0; the end type int is k's input type *)
1186 >>= fun [x] -> unit (x + 1)
1188 (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1189 >>= fun x -> unit (x, 0)
1193 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1194 let example1 () : int =
1195 Continuation_monad.(let v = reset (
1196 let u = shift (fun k -> unit (10 + 1))
1197 in u >>= fun x -> unit (100 + x)
1198 ) in let w = v >>= fun x -> unit (1000 + x)
1201 (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1203 Continuation_monad.(let v = reset (
1204 let u = shift (fun k -> k (10 :: [1]))
1205 in u >>= fun x -> unit (100 :: x)
1206 ) in let w = v >>= fun x -> unit (1000 :: x)
1209 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1211 Continuation_monad.(let v = reset (
1212 let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1213 in u >>= fun x -> unit (100 :: x)
1214 ) in let w = v >>= fun x -> unit (1000 :: x)
1217 (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1218 (* not sure if this example can be typed without a sum-type *)
1220 (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1221 let example5 () : int =
1222 Continuation_monad.(let v = reset (
1223 let u = shift (fun k -> k 1 >>= k)
1224 in u >>= fun x -> unit (10 + x)
1225 ) in let w = v >>= fun x -> unit (100 + x)
1230 print_endline "=== test bare Continuation ============";;
1232 (1011, 1111, 1111, 121);;
1233 (example1(), example2(), example3(), example5());;
1235 (example ~+10, example ~-10);;
1238 C.run_exn TC.(run (distribute df t1)) ic;;
1243 let initial_continuation = fun t -> t in
1244 TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
1249 (* count leaves, using continuation *)
1250 let initial_continuation = fun t -> 0 in
1251 TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
1254 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
1257 (* convert tree to list of leaves *)
1258 let initial_continuation = fun t -> [] in
1259 TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
1262 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
1265 (* square each leaf using continuation *)
1266 let initial_continuation = fun t -> t in
1267 TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
1270 testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
1274 (* replace leaves with list, using continuation *)
1275 let initial_continuation = fun t -> t in
1276 TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
1279 testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;
1281 print_endline "=== pa_monad's Continuation Tests ============";;
1283 (1, 5 = C.(run0 (unit 1 >>= fun x -> unit (x+4))) );;
1284 (2, 9 = C.(run0 (reset (unit 5 >>= fun x -> unit (x+4)))) );;
1285 (3, 9 = C.(run0 (reset (abort 5 >>= fun y -> unit (y+6)) >>= fun x -> unit (x+4))) );;
1286 (4, 9 = C.(run0 (reset (reset (abort 5 >>= fun y -> unit (y+6))) >>= fun x -> unit (x+4))) );;
1288 let c = reset(abort 5 >>= fun y -> unit (y+6))
1289 in reset(c >>= fun v1 -> abort 7 >>= fun v2 -> unit (v2+10) ) >>= fun x -> unit (x+20))) );;
1291 (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))) );;
1293 (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))) );;
1295 (12, ["a"] = C.(run0 (reset (shift (fun f -> f [] >>= fun t -> unit ("a"::t) ) >>= fun xv -> shift (fun _ -> unit xv)))) );;
1298 (0, 15 = C.(run0 (let f k = k 10 >>= fun v-> unit (v+100) in reset (callcc f >>= fun v -> unit (v+5)))) );;