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.
48 (* Some library functions used below. *)
50 let fold_right = List.fold_right
52 let append = List.append
53 let reverse = List.rev
54 let concat = List.concat
55 let concat_map f lst = List.concat (List.map f lst)
56 (* let zip = List.combine *)
57 let unzip = List.split
58 let zip_with = List.map2
59 let replicate len fill =
61 if n == 0 then accu else loop (pred n) (fill :: accu)
68 * This module contains factories that extend a base set of
69 * monadic definitions with a larger family of standard derived values.
74 * Signature extenders:
76 * MakeCatch, MakeDistrib :: PLUSBASE -> PLUS
79 * MakeT :: TRANS (with Wrapped : S or P) -> custom sig
81 * Make2 :: BASE2 -> S2
82 * MakeCatch2, MakeDistrib2 :: PLUSBASE2 -> PLUS2 (P2 is merged sig)
83 * to wrap double-typed inner monads:
84 * MakeT2 :: TRANS2 (with Wrapped : S2 or P2) -> custom sig
90 (* type of base definitions *)
91 module type BASE = sig
92 (* The only constraints we impose here on how the monadic type
93 * is implemented is that it have a single type parameter 'a. *)
98 val bind : 'a m -> ('a -> 'b m) -> 'b m
99 val run : 'a m -> 'a result
100 (* run_exn tries to provide a more ground-level result, but may fail *)
101 val run_exn : 'a m -> 'a result_exn
105 val (>>=) : 'a m -> ('a -> 'b m) -> 'b m
106 val (>>) : 'a m -> 'b m -> 'b m
107 val join : ('a m) m -> 'a m
108 val apply : ('a -> 'b) m -> 'a m -> 'b m
109 val lift : ('a -> 'b) -> 'a m -> 'b m
110 val lift2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m
111 val (>=>) : ('a -> 'b m) -> ('b -> 'c m) -> 'a -> 'c m
112 val do_when : bool -> unit m -> unit m
113 val do_unless : bool -> unit m -> unit m
114 val forever : 'a m -> 'b m
115 val sequence : 'a m list -> 'a list m
116 val sequence_ : 'a m list -> unit m
119 (* Standard, single-type-parameter monads. *)
120 module Make(B : BASE) : S with type 'a m = 'a B.m and type 'a result = 'a B.result and type 'a result_exn = 'a B.result_exn = struct
123 let (>>) u v = u >>= fun _ -> v
124 let lift f u = u >>= fun a -> unit (f a)
125 (* lift is called listM, fmap, and <$> in Haskell *)
126 let join uu = uu >>= fun u -> u
127 (* u >>= f === join (lift f u) *)
128 let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
129 (* [f] <*> [x1,x2] = [f x1,f x2] *)
130 (* let apply u v = u >>= fun f -> lift f v *)
131 (* let apply = lift2 id *)
132 let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
133 (* let lift f u === apply (unit f) u *)
134 (* let lift2 f u v = apply (lift f u) v *)
135 let (>=>) f g = fun a -> f a >>= g
136 let do_when test u = if test then u else unit ()
137 let do_unless test u = if test then unit () else u
138 let rec forever u = u >> forever u
140 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
141 Util.fold_right op ms (unit [])
143 Util.fold_right (>>) ms (unit ())
145 (* Haskell defines these other operations combining lists and monads.
146 * We don't, but notice that M.mapM == ListT(M).distribute
147 * There's also a parallel TreeT(M).distribute *)
149 let mapM f alist = sequence (Util.map f alist)
150 let mapM_ f alist = sequence_ (Util.map f alist)
151 let rec filterM f lst = match lst with
153 | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
154 let forM alist f = mapM f alist
155 let forM_ alist f = mapM_ f alist
156 let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
157 let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
158 let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
159 let rec foldM f z lst = match lst with
161 | x::xs -> f z x >>= fun z' -> foldM f z' xs
162 let foldM_ f z xs = foldM f z xs >> unit ()
163 let replicateM n x = sequence (Util.replicate n x)
164 let replicateM_ n x = sequence_ (Util.replicate n x)
168 (* Single-type-parameter monads that also define `plus` and `zero`
169 * operations. These obey the following laws:
170 * zero >>= f === zero
173 * Additionally, these monads will obey one of the following laws:
174 * (Catch) plus (unit a) v === unit a
175 * (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
177 module type PLUSBASE = sig
179 val zero : unit -> 'a m
180 val plus : 'a m -> 'a m -> 'a m
182 module type PLUS = sig
184 val zero : unit -> 'a m
185 val plus : 'a m -> 'a m -> 'a m
186 val guard : bool -> unit m
187 val sum : 'a m list -> 'a m
189 (* MakeCatch and MakeDistrib have the same implementation; we just declare
190 * them twice to document which laws the client code is promising to honor. *)
191 module MakeCatch(B : PLUSBASE) : PLUS with type 'a m = 'a B.m = struct
195 let guard test = if test then B.unit () else zero ()
196 let sum ms = Util.fold_right plus ms (zero ())
198 module MakeDistrib = MakeCatch
200 (* Signatures for MonadT *)
201 (* sig for Wrapped that include S and PLUS *)
204 include PLUS with type 'a m := 'a m
206 module type TRANS = sig
211 val bind : 'a m -> ('a -> 'b m) -> 'b m
212 val run : 'a m -> 'a result
213 val run_exn : 'a m -> 'a result_exn
214 val elevate : 'a Wrapped.m -> 'a m
215 (* lift/elevate laws:
216 * elevate (W.unit a) == unit a
217 * elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
220 module MakeT(T : TRANS) = struct
223 let unit a = elevate (Wrapped.unit a)
225 let elevate = T.elevate
229 (* We have to define BASE, S, and Make again for double-type-parameter monads. *)
230 module type BASE2 = sig
233 type ('x,'a) result_exn
234 val unit : 'a -> ('x,'a) m
235 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
236 val run : ('x,'a) m -> ('x,'a) result
237 val run_exn : ('x,'a) m -> ('x,'a) result_exn
241 val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
242 val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
243 val join : ('x,('x,'a) m) m -> ('x,'a) m
244 val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
245 val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
246 val lift2 : ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
247 val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
248 val do_when : bool -> ('x,unit) m -> ('x,unit) m
249 val do_unless : bool -> ('x,unit) m -> ('x,unit) m
250 val forever : ('x,'a) m -> ('x,'b) m
251 val sequence : ('x,'a) m list -> ('x,'a list) m
252 val sequence_ : ('x,'a) m list -> ('x,unit) m
254 module Make2(B : BASE2) : S2 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
255 (* code repetition, ugh *)
258 let (>>) u v = u >>= fun _ -> v
259 let lift f u = u >>= fun a -> unit (f a)
260 let join uu = uu >>= fun u -> u
261 let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
262 let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
263 let (>=>) f g = fun a -> f a >>= g
264 let do_when test u = if test then u else unit ()
265 let do_unless test u = if test then unit () else u
266 let rec forever u = u >> forever u
268 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
269 Util.fold_right op ms (unit [])
271 Util.fold_right (>>) ms (unit ())
274 module type PLUSBASE2 = sig
276 val zero : unit -> ('x,'a) m
277 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
279 module type PLUS2 = sig
281 val zero : unit -> ('x,'a) m
282 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
283 val guard : bool -> ('x,unit) m
284 val sum : ('x,'a) m list -> ('x,'a) m
286 module MakeCatch2(B : PLUSBASE2) : PLUS2 with type ('x,'a) m = ('x,'a) B.m = struct
287 type ('x,'a) m = ('x,'a) B.m
288 (* code repetition, ugh *)
291 let guard test = if test then B.unit () else zero ()
292 let sum ms = Util.fold_right plus ms (zero ())
294 module MakeDistrib2 = MakeCatch2
296 (* Signatures for MonadT *)
297 (* sig for Wrapped that include S and PLUS *)
300 include PLUS2 with type ('x,'a) m := ('x,'a) m
302 module type TRANS2 = sig
306 type ('x,'a) result_exn
307 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
308 val run : ('x,'a) m -> ('x,'a) result
309 val run_exn : ('x,'a) m -> ('x,'a) result_exn
310 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
312 module MakeT2(T : TRANS2) = struct
313 (* code repetition, ugh *)
316 let unit a = elevate (Wrapped.unit a)
318 let elevate = T.elevate
327 module Identity_monad : sig
328 (* expose only the implementation of type `'a result` *)
330 type 'a result_exn = 'a
331 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
339 type 'a result_exn = 'a
342 include Monad.Make(Base)
346 module Maybe_monad : sig
347 (* expose only the implementation of type `'a result` *)
348 type 'a result = 'a option
349 type 'a result_exn = 'a
350 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
351 include Monad.PLUS with type 'a m := 'a m
352 (* MaybeT transformer *)
353 module T : functor (Wrapped : Monad.S) -> sig
354 type 'a result = 'a option Wrapped.result
355 type 'a result_exn = 'a Wrapped.result_exn
356 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
357 include Monad.PLUS with type 'a m := 'a m
358 val elevate : 'a Wrapped.m -> 'a m
360 module T2 : functor (Wrapped : Monad.S2) -> sig
361 type ('x,'a) result = ('x,'a option) Wrapped.result
362 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
363 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
364 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
365 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
369 type 'a m = 'a option
371 let bind u f = match u with Some a -> f a | None -> None
372 type 'a result = 'a option
374 type 'a result_exn = 'a
375 let run_exn u = match u with
377 | None -> failwith "no value"
379 let plus u v = match u with None -> v | _ -> u
381 include Monad.Make(Base)
382 include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m)
383 module T(Wrapped : Monad.S) = struct
384 module Trans = struct
385 include Monad.MakeT(struct
386 module Wrapped = Wrapped
387 type 'a m = 'a option Wrapped.m
388 type 'a result = 'a option Wrapped.result
389 type 'a result_exn = 'a Wrapped.result_exn
390 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
391 let bind u f = Wrapped.bind u (fun t -> match t with
393 | None -> Wrapped.unit None)
394 let run u = Wrapped.run u
396 let w = Wrapped.bind u (fun t -> match t with
397 | Some a -> Wrapped.unit a
398 | None -> failwith "no value")
401 let zero () = Wrapped.unit None
402 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
405 include (Monad.MakeCatch(Trans) : Monad.PLUS with type 'a m := 'a m)
407 module T2(Wrapped : Monad.S2) = struct
408 module Trans = struct
409 include Monad.MakeT2(struct
410 module Wrapped = Wrapped
411 type ('x,'a) m = ('x,'a option) Wrapped.m
412 type ('x,'a) result = ('x,'a option) Wrapped.result
413 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
414 (* code repetition, ugh *)
415 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
416 let bind u f = Wrapped.bind u (fun t -> match t with
418 | None -> Wrapped.unit None)
419 let run u = Wrapped.run u
421 let w = Wrapped.bind u (fun t -> match t with
422 | Some a -> Wrapped.unit a
423 | None -> failwith "no value")
426 let zero () = Wrapped.unit None
427 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
430 include (Monad.MakeCatch2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
435 module List_monad : sig
436 (* declare additional operation, while still hiding implementation of type m *)
437 type 'a result = 'a list
438 type 'a result_exn = 'a
439 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
440 include Monad.PLUS with type 'a m := 'a m
441 val permute : 'a m -> 'a m m
442 val select : 'a m -> ('a * 'a m) m
443 (* ListT transformer *)
444 module T : functor (Wrapped : Monad.S) -> sig
445 type 'a result = 'a list Wrapped.result
446 type 'a result_exn = 'a Wrapped.result_exn
447 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
448 include Monad.PLUS with type 'a m := 'a m
449 val elevate : 'a Wrapped.m -> 'a m
450 (* note that second argument is an 'a list, not the more abstract 'a m *)
451 (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
452 val distribute : ('a -> 'b Wrapped.m) -> 'a list -> 'b m
454 val permute : 'a m -> 'a m m
455 val select : 'a m -> ('a * 'a m) m
459 module T2 : functor (Wrapped : Monad.S2) -> sig
460 type ('x,'a) result = ('x,'a list) Wrapped.result
461 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
462 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
463 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
464 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
465 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
472 let bind u f = Util.concat_map f u
473 type 'a result = 'a list
475 type 'a result_exn = 'a
476 let run_exn u = match u with
477 | [] -> failwith "no values"
479 | many -> failwith "multiple values"
481 let plus = Util.append
483 include Monad.Make(Base)
484 include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
485 (* let either u v = plus u v *)
486 (* insert 3 [1;2] ~~> [[3;1;2]; [1;3;2]; [1;2;3]] *)
488 plus (unit (a :: u)) (match u with
490 | x :: xs -> (insert a xs) >>= fun v -> unit (x :: v)
492 (* permute [1;2;3] ~~> [1;2;3]; [2;1;3]; [2;3;1]; [1;3;2]; [3;1;2]; [3;2;1] *)
493 let rec permute u = match u with
495 | x :: xs -> (permute xs) >>= (fun v -> insert x v)
496 (* select [1;2;3] ~~> [(1,[2;3]); (2,[1;3]), (3;[1;2])] *)
497 let rec select u = match u with
499 | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
501 module T(Wrapped : Monad.S) = struct
502 module Trans = struct
503 let zero () = Wrapped.unit []
505 Wrapped.bind u (fun us ->
506 Wrapped.bind v (fun vs ->
507 Wrapped.unit (base_plus us vs)))
508 (* Wrapped.sequence ms ===
510 Wrapped.bind u (fun x ->
511 Wrapped.bind v (fun xs ->
512 Wrapped.unit (x :: xs)))
513 in Util.fold_right plus1 ms (Wrapped.unit []) *)
514 (* distribute === Wrapped.mapM; copies alist to its image under f *)
515 let distribute f alist = Wrapped.sequence (Util.map f alist)
516 include Monad.MakeT(struct
517 module Wrapped = Wrapped
518 type 'a m = 'a list Wrapped.m
519 type 'a result = 'a list Wrapped.result
520 type 'a result_exn = 'a Wrapped.result_exn
521 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
523 Wrapped.bind u (fun ts ->
524 Wrapped.bind (distribute f ts) (fun tts ->
525 Wrapped.unit (Util.concat tts)))
526 let run u = Wrapped.run u
528 let w = Wrapped.bind u (fun ts -> match ts with
529 | [] -> failwith "no values"
530 | [a] -> Wrapped.unit a
531 | many -> failwith "multiple values"
532 ) in Wrapped.run_exn w
536 include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
538 let permute : 'a m -> 'a m m
539 let select : 'a m -> ('a * 'a m) m
545 (* must be parameterized on (struct type err = ... end) *)
546 module Error_monad(Err : sig
550 val zero : unit -> err
551 val plus : err -> err -> err
554 (* declare additional operations, while still hiding implementation of type m *)
556 type 'a error = Error of err | Success of 'a
558 type 'a result_exn = 'a
559 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
560 (* include Monad.PLUS with type 'a m := 'a m *)
561 val throw : err -> 'a m
562 val catch : 'a m -> (err -> 'a m) -> 'a m
563 (* ErrorT transformer *)
564 module T : functor (Wrapped : Monad.S) -> sig
565 type 'a result = 'a Wrapped.result
566 type 'a result_exn = 'a Wrapped.result_exn
567 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
568 val elevate : 'a Wrapped.m -> 'a m
569 val throw : err -> 'a m
570 val catch : 'a m -> (err -> 'a m) -> 'a m
574 type 'a error = Error of err | Success of 'a
577 let unit a = Success a
578 let bind u f = match u with
580 | Error e -> Error e (* input and output may be of different 'a types *)
582 (* TODO: should run refrain from failing? *)
583 let run u = match u with
585 | Error e -> raise (Err.Exc e)
586 type 'a result_exn = 'a
589 let zero () = Error Err.zero
590 let plus u v = match (u, v) with
592 (* to satisfy (Catch) laws, plus u zero = u, even if u = Error _
593 * otherwise, plus (Error _) v = v *)
594 | Error _, _ when v = zero -> u
596 | Error e1, Error e2 when u <> zero -> Error (Err.plus e1 e2)
600 include Monad.Make(Base)
601 (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
602 let throw e = Error e
603 let catch u handler = match u with
605 | Error e -> handler e
606 module T(Wrapped : Monad.S) = struct
607 module Trans = struct
608 module Wrapped = Wrapped
609 type 'a m = 'a Base.m Wrapped.m
610 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
611 let bind u f = Wrapped.bind u (fun t -> match t with
613 | Error e -> Wrapped.unit (Error e))
614 type 'a result = 'a Wrapped.result
615 (* TODO: should run refrain from failing? *)
617 let w = Wrapped.bind u (fun t -> match t with
618 | Success a -> Wrapped.unit a
619 (* | _ -> Wrapped.fail () *)
620 | Error e -> raise (Err.Exc e))
622 type 'a result_exn = 'a Wrapped.result_exn
624 let w = Wrapped.bind u (fun t -> match t with
625 | Success a -> Wrapped.unit a
626 (* | _ -> Wrapped.fail () *)
627 | Error e -> raise (Err.Exc e))
630 include Monad.MakeT(Trans)
631 let throw e = Wrapped.unit (Error e)
632 let catch u handler = Wrapped.bind u (fun t -> match t with
633 | Success _ -> Wrapped.unit t
634 | Error e -> handler e)
638 (* pre-define common instance of Error_monad *)
639 module Failure = Error_monad(struct
641 exception Exc = Failure
644 let plus s1 s2 = s1 ^ "\n" ^ s2
648 (* must be parameterized on (struct type env = ... end) *)
649 module Reader_monad(Env : sig type env end) : sig
650 (* declare additional operations, while still hiding implementation of type m *)
652 type 'a result = env -> 'a
653 type 'a result_exn = env -> 'a
654 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
656 val asks : (env -> 'a) -> 'a m
657 val local : (env -> env) -> 'a m -> 'a m
658 (* ReaderT transformer *)
659 module T : functor (Wrapped : Monad.S) -> sig
660 type 'a result = env -> 'a Wrapped.result
661 type 'a result_exn = env -> 'a Wrapped.result_exn
662 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
663 val elevate : 'a Wrapped.m -> 'a m
665 val asks : (env -> 'a) -> 'a m
666 val local : (env -> env) -> 'a m -> 'a m
668 (* ReaderT transformer when wrapped monad has plus, zero *)
669 module TP : functor (Wrapped : Monad.P) -> sig
670 include module type of T(Wrapped)
671 include Monad.PLUS with type 'a m := 'a m
676 type 'a m = env -> 'a
677 let unit a = fun e -> a
678 let bind u f = fun e -> let a = u e in let u' = f a in u' e
679 type 'a result = env -> 'a
680 let run u = fun e -> u e
681 type 'a result_exn = env -> 'a
684 include Monad.Make(Base)
686 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
687 let local modifier u = fun e -> u (modifier e)
688 module T(Wrapped : Monad.S) = struct
689 module Trans = struct
690 module Wrapped = Wrapped
691 type 'a m = env -> 'a Wrapped.m
692 let elevate w = fun e -> w
693 let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
694 type 'a result = env -> 'a Wrapped.result
695 let run u = fun e -> Wrapped.run (u e)
696 type 'a result_exn = env -> 'a Wrapped.result_exn
697 let run_exn u = fun e -> Wrapped.run_exn (u e)
699 include Monad.MakeT(Trans)
700 let ask = fun e -> Wrapped.unit e
701 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
702 let local modifier u = fun e -> u (modifier e)
704 module TP(Wrapped : Monad.P) = struct
705 module TransP = struct
707 let plus u v = fun s -> Wrapped.plus (u s) (v s)
708 let zero () = elevate (Wrapped.zero ())
709 let asks selector = ask >>= (fun e ->
710 try unit (selector e)
711 with Not_found -> fun e -> Wrapped.zero ())
714 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
719 (* must be parameterized on (struct type store = ... end) *)
720 module State_monad(Store : sig type store end) : sig
721 (* declare additional operations, while still hiding implementation of type m *)
722 type store = Store.store
723 type 'a result = store -> 'a * store
724 type 'a result_exn = store -> 'a
725 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
727 val gets : (store -> 'a) -> 'a m
728 val put : store -> unit m
729 val puts : (store -> store) -> unit m
730 (* StateT transformer *)
731 module T : functor (Wrapped : Monad.S) -> sig
732 type 'a result = store -> ('a * store) Wrapped.result
733 type 'a result_exn = store -> 'a Wrapped.result_exn
734 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
735 val elevate : 'a Wrapped.m -> 'a m
737 val gets : (store -> 'a) -> 'a m
738 val put : store -> unit m
739 val puts : (store -> store) -> unit m
741 (* StateT transformer when wrapped monad has plus, zero *)
742 module TP : functor (Wrapped : Monad.P) -> sig
743 include module type of T(Wrapped)
744 include Monad.PLUS with type 'a m := 'a m
747 type store = Store.store
749 type 'a m = store -> 'a * store
750 let unit a = fun s -> (a, s)
751 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
752 type 'a result = store -> 'a * store
753 let run u = fun s -> (u s)
754 type 'a result_exn = store -> 'a
755 let run_exn u = fun s -> fst (u s)
757 include Monad.Make(Base)
758 let get = fun s -> (s, s)
759 let gets viewer = fun s -> (viewer s, s) (* may fail *)
760 let put s = fun _ -> ((), s)
761 let puts modifier = fun s -> ((), modifier s)
762 module T(Wrapped : Monad.S) = struct
763 module Trans = struct
764 module Wrapped = Wrapped
765 type 'a m = store -> ('a * store) Wrapped.m
766 let elevate w = fun s ->
767 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
768 let bind u f = fun s ->
769 Wrapped.bind (u s) (fun (a, s') -> f a s')
770 type 'a result = store -> ('a * store) Wrapped.result
771 let run u = fun s -> Wrapped.run (u s)
772 type 'a result_exn = store -> 'a Wrapped.result_exn
773 let run_exn u = fun s ->
774 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
777 include Monad.MakeT(Trans)
778 let get = fun s -> Wrapped.unit (s, s)
779 let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
780 let put s = fun _ -> Wrapped.unit ((), s)
781 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
783 module TP(Wrapped : Monad.P) = struct
784 module TransP = struct
786 let plus u v = fun s -> Wrapped.plus (u s) (v s)
787 let zero () = elevate (Wrapped.zero ())
789 let gets viewer = fun s ->
790 try Wrapped.unit (viewer s, s)
791 with Not_found -> Wrapped.zero ()
793 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
797 (* State monad with different interface (structured store) *)
798 module Ref_monad(V : sig
804 type 'a result_exn = 'a
805 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
806 val newref : value -> ref m
807 val deref : ref -> value m
808 val change : ref -> value -> unit m
809 (* RefT transformer *)
810 module T : functor (Wrapped : Monad.S) -> sig
811 type 'a result = 'a Wrapped.result
812 type 'a result_exn = 'a Wrapped.result_exn
813 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
814 val elevate : 'a Wrapped.m -> 'a m
815 val newref : value -> ref m
816 val deref : ref -> value m
817 val change : ref -> value -> unit m
819 (* RefT transformer when wrapped monad has plus, zero *)
820 module TP : functor (Wrapped : Monad.P) -> sig
821 include module type of T(Wrapped)
822 include Monad.PLUS with type 'a m := 'a m
827 module D = Map.Make(struct type t = ref let compare = compare end)
828 type dict = { next: ref; tree : value D.t }
829 let empty = { next = 0; tree = D.empty }
830 let alloc (value : value) (d : dict) =
831 (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
832 let read (key : ref) (d : dict) =
834 let write (key : ref) (value : value) (d : dict) =
835 { next = d.next; tree = D.add key value d.tree }
837 type 'a m = dict -> 'a * dict
838 let unit a = fun s -> (a, s)
839 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
841 let run u = fst (u empty)
842 type 'a result_exn = 'a
845 include Monad.Make(Base)
846 let newref value = fun s -> alloc value s
847 let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
848 let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
849 module T(Wrapped : Monad.S) = struct
850 module Trans = struct
851 module Wrapped = Wrapped
852 type 'a m = dict -> ('a * dict) Wrapped.m
853 let elevate w = fun s ->
854 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
855 let bind u f = fun s ->
856 Wrapped.bind (u s) (fun (a, s') -> f a s')
857 type 'a result = 'a Wrapped.result
859 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
861 type 'a result_exn = 'a Wrapped.result_exn
863 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
866 include Monad.MakeT(Trans)
867 let newref value = fun s -> Wrapped.unit (alloc value s)
868 let deref key = fun s -> Wrapped.unit (read key s, s)
869 let change key value = fun s -> Wrapped.unit ((), write key value s)
871 module TP(Wrapped : Monad.P) = struct
872 module TransP = struct
874 let plus u v = fun s -> Wrapped.plus (u s) (v s)
875 let zero () = elevate (Wrapped.zero ())
878 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
883 (* must be parameterized on (struct type log = ... end) *)
884 module Writer_monad(Log : sig
887 val plus : log -> log -> log
889 (* declare additional operations, while still hiding implementation of type m *)
891 type 'a result = 'a * log
892 type 'a result_exn = 'a * log
893 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
894 val tell : log -> unit m
895 val listen : 'a m -> ('a * log) m
896 val listens : (log -> 'b) -> 'a m -> ('a * 'b) m
897 (* val pass : ('a * (log -> log)) m -> 'a m *)
898 val censor : (log -> log) -> 'a m -> 'a m
903 let unit a = (a, Log.zero)
904 let bind (a, w) f = let (a', w') = f a in (a', Log.plus w w')
905 type 'a result = 'a * log
907 type 'a result_exn = 'a * log
910 include Monad.Make(Base)
911 let tell entries = ((), entries) (* add entries to log *)
912 let listen (a, w) = ((a, w), w)
913 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
914 let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
915 let censor f u = pass (u >>= fun a -> unit (a, f))
918 (* pre-define simple Writer *)
919 module Writer1 = Writer_monad(struct
922 let plus s1 s2 = s1 ^ "\n" ^ s2
925 (* slightly more efficient Writer *)
926 module Writer2 = struct
927 include Writer_monad(struct
928 type log = string list
930 let plus w w' = Util.append w' w
932 let tell_string s = tell [s]
933 let tell entries = tell (Util.reverse entries)
934 let run u = let (a, w) = run u in (a, Util.reverse w)
939 module IO_monad : sig
940 (* declare additional operation, while still hiding implementation of type m *)
942 type 'a result_exn = 'a
943 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
944 val printf : ('a, unit, string, unit m) format4 -> 'a
945 val print_string : string -> unit m
946 val print_int : int -> unit m
947 val print_hex : int -> unit m
948 val print_bool : bool -> unit m
951 type 'a m = { run : unit -> unit; value : 'a }
952 let unit a = { run = (fun () -> ()); value = a }
953 let bind (a : 'a m) (f: 'a -> 'b m) : 'b m =
954 let fres = f a.value in
955 { run = (fun () -> a.run (); fres.run ()); value = fres.value }
957 let run a = let () = a.run () in a.value
958 type 'a result_exn = 'a
961 include Monad.Make(Base)
963 Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
964 let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
965 let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
966 let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
967 let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
970 module Continuation_monad : sig
971 (* expose only the implementation of type `('r,'a) result` *)
973 type 'a result = 'a m
974 type 'a result_exn = 'a m
975 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn and type 'a m := 'a m
976 (* val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m *)
977 (* misses that the answer types of all the cont's must be the same *)
978 val callcc : (('a -> 'b m) -> 'a m) -> 'a m
979 (* val reset : ('a,'a) m -> ('r,'a) m *)
980 val reset : 'a m -> 'a m
981 (* val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m *)
982 (* misses that the answer types of second and third continuations must be b *)
983 val shift : (('a -> 'b m) -> 'b m) -> 'a m
984 (* overwrite the run declaration in S, because I can't declare 'a result =
985 * this polymorphic type (complains that 'r is unbound *)
986 val runk : 'a m -> ('a -> 'r) -> 'r
987 val run0 : 'a m -> 'a
991 (* 'r is result type of whole computation *)
992 type 'a m = { cont : 'r. ('a -> 'r) -> 'r }
994 let cont : 'r. ('a -> 'r) -> 'r =
998 let cont : 'r. ('a -> 'r) -> 'r =
999 fun k -> u.cont (fun a -> (f a).cont k)
1001 type 'a result = 'a m
1002 let run (u : 'a m) : 'a result = u
1003 type 'a result_exn = 'a m
1004 let run_exn (u : 'a m) : 'a result_exn = u
1006 let cont : 'r. ('a -> 'r) -> 'r =
1007 (* Can't figure out how to make the type polymorphic enough
1008 * to satisfy the OCaml type-checker (it's ('a -> 'r) -> 'r
1009 * instead of 'r. ('a -> 'r) -> 'r); so we have to fudge
1010 * with Obj.magic... which tells OCaml's type checker to
1011 * relax, the supplied value has whatever type the context
1012 * needs it to have. *)
1014 let usek a = { cont = Obj.magic (fun _ -> k a) }
1017 let reset u = unit (u.cont id)
1018 let shift (f : ('a -> 'b m) -> 'b m) : 'a m =
1020 (f (fun a -> unit (k a))).cont id
1021 in { cont = Obj.magic cont }
1022 let runk u k = (u.cont : ('a -> 'r) -> 'r) k
1023 let run0 u = runk u id
1025 include Monad.Make(Base)
1026 let callcc = Base.callcc
1027 let reset = Base.reset
1028 let shift = Base.shift
1029 let runk = Base.runk
1030 let run0 = Base.run0
1034 (* This two-type parameter version works without Obj.magic *)
1036 module Continuation_monad2 : sig
1037 (* expose only the implementation of type `('r,'a) result` *)
1038 type ('r,'a) result = ('a -> 'r) -> 'r
1039 type ('r,'a) result_exn = ('a -> 'r) -> 'r
1040 include Monad.S2 with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn
1041 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
1042 val reset : ('a,'a) m -> ('r,'a) m
1043 val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
1047 module Base = struct
1048 (* 'r is result type of whole computation *)
1049 type ('r,'a) m = ('a -> 'r) -> 'r
1050 let unit a = fun k -> k a
1051 let bind u f = fun k -> u (fun a -> (f a) k)
1052 type ('r,'a) result = ('a -> 'r) -> 'r
1054 type ('r,'a) result_exn = ('a -> 'r) -> 'r
1057 include Monad.Make2(Base)
1058 let callcc f = fun k ->
1059 let usek a = fun _ -> k a
1062 val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
1063 val throw : ('a -> 'r) -> 'a -> ('r,'b) m
1064 let callcc f = fun k -> f k k
1065 let throw k a = fun _ -> k a
1067 (* from http://www.haskell.org/haskellwiki/MonadCont_done_right *)
1068 let reset u = unit (u id)
1069 let shift u = fun k -> u (fun a -> unit (k a)) id
1076 * (define (example n)
1077 * (let ([u (let/cc k ; type int -> int pair
1078 * (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
1079 * (+ 1 (car v))))]) ; int
1080 * (cons u 0))) ; int pair
1081 * ; (example 10) ~~> '(111 . 0)
1082 * ; (example -10) ~~> '(0 . 0)
1085 * let example n : (int * int) =
1086 * Continuation_monad.(let u = callcc (fun k ->
1087 * (if n < 0 then k 0 else unit [n + 100])
1088 * (* all of the following is skipped by k 0; the end type int is k's input type *)
1089 * >>= fun [x] -> unit (x + 1)
1091 * (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1092 * >>= fun x -> unit (x, 0)
1096 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1097 * let example1 () : int =
1098 * Continuation_monad.(let v = reset (
1099 * let u = shift (fun k -> unit (10 + 1))
1100 * in u >>= fun x -> unit (100 + x)
1101 * ) in let w = v >>= fun x -> unit (1000 + x)
1104 * (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1106 * Continuation_monad.(let v = reset (
1107 * let u = shift (fun k -> k (10 :: [1]))
1108 * in u >>= fun x -> unit (100 :: x)
1109 * ) in let w = v >>= fun x -> unit (1000 :: x)
1112 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1114 * Continuation_monad.(let v = reset (
1115 * let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1116 * in u >>= fun x -> unit (100 :: x)
1117 * ) in let w = v >>= fun x -> unit (1000 :: x)
1120 * (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1121 * (* not sure if this example can be typed without a sum-type *)
1123 * (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1124 * let example5 () : int =
1125 * Continuation_monad.(let v = reset (
1126 * let u = shift (fun k -> k 1 >>= fun x -> k x)
1127 * in u >>= fun x -> unit (10 + x)
1128 * ) in let w = v >>= fun x -> unit (100 + x)
1134 module Leaf_monad : sig
1135 (* We implement the type as `'a tree option` because it has a natural`plus`,
1136 * and the rest of the library expects that `plus` and `zero` will come together. *)
1137 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1138 type 'a result = 'a tree option
1139 type 'a result_exn = 'a tree
1140 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1141 include Monad.PLUS with type 'a m := 'a m
1142 (* LeafT transformer *)
1143 module T : functor (Wrapped : Monad.S) -> sig
1144 type 'a result = 'a tree option Wrapped.result
1145 type 'a result_exn = 'a tree Wrapped.result_exn
1146 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1147 include Monad.PLUS with type 'a m := 'a m
1148 val elevate : 'a Wrapped.m -> 'a m
1149 (* note that second argument is an 'a tree?, not the more abstract 'a m *)
1150 (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
1151 val distribute : ('a -> 'b Wrapped.m) -> 'a tree option -> 'b m
1154 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1155 (* uses supplied plus and zero to copy t to its image under f *)
1156 let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
1158 | Some ts -> let rec loop ts = (match ts with
1161 (* recursive application of f may delete a branch *)
1162 plus (loop l) (loop r)
1164 module Base = struct
1165 type 'a m = 'a tree option
1166 let unit a = Some (Leaf a)
1168 let plus u v = match (u, v) with
1171 | Some us, Some vs -> Some (Node (us, vs))
1172 let bind u f = mapT f u zero plus
1173 type 'a result = 'a tree option
1175 type 'a result_exn = 'a tree
1176 let run_exn u = match u with
1177 | None -> failwith "no values"
1179 | Some (Leaf a) -> a
1180 | many -> failwith "multiple values"
1184 include Monad.Make(Base)
1185 include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
1186 let base_plus = plus
1187 let base_lift = lift
1188 module T(Wrapped : Monad.S) = struct
1189 module Trans = struct
1190 let zero () = Wrapped.unit None
1192 Wrapped.bind u (fun us ->
1193 Wrapped.bind v (fun vs ->
1194 Wrapped.unit (base_plus us vs)))
1195 include Monad.MakeT(struct
1196 module Wrapped = Wrapped
1197 type 'a m = 'a Base.m Wrapped.m
1198 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1199 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1200 type 'a result = 'a tree option Wrapped.result
1201 let run u = Wrapped.run u
1202 type 'a result_exn = 'a tree Wrapped.result_exn
1204 let w = Wrapped.bind u (fun t -> match t with
1205 | None -> failwith "no values"
1206 | Some ts -> Wrapped.unit ts)
1207 in Wrapped.run_exn w
1211 include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
1212 (* let distribute f t = mapT (fun a -> a) (base_lift (fun a -> elevate (f a)) t) zero plus *)
1213 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1218 module L = List_monad;;
1219 module R = Reader_monad(struct type env = int -> int end);;
1220 module S = State_monad(struct type store = int end);;
1221 module T = Leaf_monad;;
1222 module LR = L.T(R);;
1223 module LS = L.T(S);;
1224 module TL = T.T(L);;
1225 module TR = T.T(R);;
1226 module TS = T.T(S);;
1228 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))));;
1231 let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
1234 - : int T.tree option * S.store =
1237 (T.Node (T.Leaf 2, T.Leaf 3),
1238 T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
1242 let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
1245 - : (int * S.store) T.tree option * S.store =
1248 (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
1249 T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
1253 let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
1254 TR.run_exn tr (fun i -> i+i);;
1256 - : int T.tree option =
1259 (T.Node (T.Leaf 4, T.Leaf 6),
1260 T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
1263 let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
1266 - : (int * int) TL.result =
1269 (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
1270 T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
1273 let l2 = [1;2;3;4;5];;
1274 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))));;
1276 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);;
1277 (* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
1279 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);;
1284 (T.Node (T.Leaf 10, T.Leaf 11),
1287 (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
1288 T.Node (T.Leaf 40, T.Leaf 41)),
1289 T.Node (T.Leaf 50, T.Leaf 51))))
1292 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;;
1294 - : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
1299 let id : 'z. 'z -> 'z = fun x -> x
1301 let example n : (int * int) =
1302 Continuation_monad.(let u = callcc (fun k ->
1303 (if n < 0 then k 0 else unit [n + 100])
1304 (* all of the following is skipped by k 0; the end type int is k's input type *)
1305 >>= fun [x] -> unit (x + 1)
1307 (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1308 >>= fun x -> unit (x, 0)
1312 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1313 let example1 () : int =
1314 Continuation_monad.(let v = reset (
1315 let u = shift (fun k -> unit (10 + 1))
1316 in u >>= fun x -> unit (100 + x)
1317 ) in let w = v >>= fun x -> unit (1000 + x)
1320 (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1322 Continuation_monad.(let v = reset (
1323 let u = shift (fun k -> k (10 :: [1]))
1324 in u >>= fun x -> unit (100 :: x)
1325 ) in let w = v >>= fun x -> unit (1000 :: x)
1328 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1330 Continuation_monad.(let v = reset (
1331 let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1332 in u >>= fun x -> unit (100 :: x)
1333 ) in let w = v >>= fun x -> unit (1000 :: x)
1336 (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1337 (* not sure if this example can be typed without a sum-type *)
1339 (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1340 let example5 () : int =
1341 Continuation_monad.(let v = reset (
1342 let u = shift (fun k -> k 1 >>= fun x -> k x)
1343 in u >>= fun x -> unit (10 + x)
1344 ) in let w = v >>= fun x -> unit (100 + x)
1350 (1011, 1111, 1111, 121);;
1351 (example1(), example2(), example3(), example5());;
1353 (example ~+10, example ~-10);;
1355 module C = Continuation_monad
1359 C.runk TC.(run_exn (distribute df t1)) ic;;
1364 let initial_continuation = fun t -> t in
1365 TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
1370 (* count leaves, using continuation *)
1371 let initial_continuation = fun t -> 0 in
1372 TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
1375 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
1378 (* convert tree to list of leaves *)
1379 let initial_continuation = fun t -> [] in
1380 TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
1383 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
1386 (* square each leaf using continuation *)
1387 let initial_continuation = fun t -> t in
1388 TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
1391 testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
1395 (* replace leaves with list, using continuation *)
1396 let initial_continuation = fun t -> t in
1397 TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
1400 testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;