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 : (unit -> '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
139 let rec loop () = uthunk () >>= fun _ -> loop ()
142 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
143 Util.fold_right op ms (unit [])
145 Util.fold_right (>>) ms (unit ())
147 (* Haskell defines these other operations combining lists and monads.
148 * We don't, but notice that M.mapM == ListT(M).distribute
149 * There's also a parallel TreeT(M).distribute *)
151 let mapM f alist = sequence (Util.map f alist)
152 let mapM_ f alist = sequence_ (Util.map f alist)
153 let rec filterM f lst = match lst with
155 | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
156 let forM alist f = mapM f alist
157 let forM_ alist f = mapM_ f alist
158 let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
159 let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
160 let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
161 let rec foldM f z lst = match lst with
163 | x::xs -> f z x >>= fun z' -> foldM f z' xs
164 let foldM_ f z xs = foldM f z xs >> unit ()
165 let replicateM n x = sequence (Util.replicate n x)
166 let replicateM_ n x = sequence_ (Util.replicate n x)
170 (* Single-type-parameter monads that also define `plus` and `zero`
171 * operations. These obey the following laws:
172 * zero >>= f === zero
175 * Additionally, these monads will obey one of the following laws:
176 * (Catch) plus (unit a) v === unit a
177 * (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
179 module type PLUSBASE = sig
181 val zero : unit -> 'a m
182 val plus : 'a m -> 'a m -> 'a m
184 module type PLUS = sig
186 val zero : unit -> 'a m
187 val plus : 'a m -> 'a m -> 'a m
188 val guard : bool -> unit m
189 val sum : 'a m list -> 'a m
191 (* MakeCatch and MakeDistrib have the same implementation; we just declare
192 * them twice to document which laws the client code is promising to honor. *)
193 module MakeCatch(B : PLUSBASE) : PLUS with type 'a m = 'a B.m = struct
197 let guard test = if test then B.unit () else zero ()
198 let sum ms = Util.fold_right plus ms (zero ())
200 module MakeDistrib = MakeCatch
202 (* Signatures for MonadT *)
203 (* sig for Wrapped that include S and PLUS *)
206 include PLUS with type 'a m := 'a m
208 module type TRANS = sig
213 val bind : 'a m -> ('a -> 'b m) -> 'b m
214 val run : 'a m -> 'a result
215 val run_exn : 'a m -> 'a result_exn
216 val elevate : 'a Wrapped.m -> 'a m
217 (* lift/elevate laws:
218 * elevate (W.unit a) == unit a
219 * elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
222 module MakeT(T : TRANS) = struct
225 let unit a = elevate (Wrapped.unit a)
227 let elevate = T.elevate
231 (* We have to define BASE, S, and Make again for double-type-parameter monads. *)
232 module type BASE2 = sig
235 type ('x,'a) result_exn
236 val unit : 'a -> ('x,'a) m
237 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
238 val run : ('x,'a) m -> ('x,'a) result
239 val run_exn : ('x,'a) m -> ('x,'a) result_exn
243 val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
244 val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
245 val join : ('x,('x,'a) m) m -> ('x,'a) m
246 val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
247 val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
248 val lift2 : ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
249 val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
250 val do_when : bool -> ('x,unit) m -> ('x,unit) m
251 val do_unless : bool -> ('x,unit) m -> ('x,unit) m
252 val forever : (unit -> ('x,'a) m) -> ('x,'b) m
253 val sequence : ('x,'a) m list -> ('x,'a list) m
254 val sequence_ : ('x,'a) m list -> ('x,unit) m
256 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
257 (* code repetition, ugh *)
260 let (>>) u v = u >>= fun _ -> v
261 let lift f u = u >>= fun a -> unit (f a)
262 let join uu = uu >>= fun u -> u
263 let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
264 let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
265 let (>=>) f g = fun a -> f a >>= g
266 let do_when test u = if test then u else unit ()
267 let do_unless test u = if test then unit () else u
269 let rec loop () = uthunk () >>= fun _ -> loop ()
272 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
273 Util.fold_right op ms (unit [])
275 Util.fold_right (>>) ms (unit ())
278 module type PLUSBASE2 = sig
280 val zero : unit -> ('x,'a) m
281 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
283 module type PLUS2 = sig
285 val zero : unit -> ('x,'a) m
286 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
287 val guard : bool -> ('x,unit) m
288 val sum : ('x,'a) m list -> ('x,'a) m
290 module MakeCatch2(B : PLUSBASE2) : PLUS2 with type ('x,'a) m = ('x,'a) B.m = struct
291 type ('x,'a) m = ('x,'a) B.m
292 (* code repetition, ugh *)
295 let guard test = if test then B.unit () else zero ()
296 let sum ms = Util.fold_right plus ms (zero ())
298 module MakeDistrib2 = MakeCatch2
300 (* Signatures for MonadT *)
301 (* sig for Wrapped that include S and PLUS *)
304 include PLUS2 with type ('x,'a) m := ('x,'a) m
306 module type TRANS2 = sig
310 type ('x,'a) result_exn
311 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
312 val run : ('x,'a) m -> ('x,'a) result
313 val run_exn : ('x,'a) m -> ('x,'a) result_exn
314 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
316 module MakeT2(T : TRANS2) = struct
317 (* code repetition, ugh *)
320 let unit a = elevate (Wrapped.unit a)
322 let elevate = T.elevate
331 module Identity_monad : sig
332 (* expose only the implementation of type `'a result` *)
334 type 'a result_exn = 'a
335 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
340 type 'a result_exn = 'a
346 include Monad.Make(Base)
350 module Maybe_monad : sig
351 (* expose only the implementation of type `'a result` *)
352 type 'a result = 'a option
353 type 'a result_exn = 'a
354 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
355 include Monad.PLUS with type 'a m := 'a m
356 (* MaybeT transformer *)
357 module T : functor (Wrapped : Monad.S) -> sig
358 type 'a result = 'a option Wrapped.result
359 type 'a result_exn = 'a Wrapped.result_exn
360 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
361 include Monad.PLUS with type 'a m := 'a m
362 val elevate : 'a Wrapped.m -> 'a m
364 module T2 : functor (Wrapped : Monad.S2) -> sig
365 type ('x,'a) result = ('x,'a option) Wrapped.result
366 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
367 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
368 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
369 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
373 type 'a m = 'a option
374 type 'a result = 'a option
375 type 'a result_exn = 'a
377 let bind u f = match u with Some a -> f a | None -> None
379 let run_exn u = match u with
381 | None -> failwith "no value"
383 let plus u v = match u with None -> v | _ -> u
385 include Monad.Make(Base)
386 include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m)
387 module T(Wrapped : Monad.S) = struct
388 module Trans = struct
389 include Monad.MakeT(struct
390 module Wrapped = Wrapped
391 type 'a m = 'a option Wrapped.m
392 type 'a result = 'a option Wrapped.result
393 type 'a result_exn = 'a Wrapped.result_exn
394 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
395 let bind u f = Wrapped.bind u (fun t -> match t with
397 | None -> Wrapped.unit None)
398 let run u = Wrapped.run u
400 let w = Wrapped.bind u (fun t -> match t with
401 | Some a -> Wrapped.unit a
402 | None -> failwith "no value")
405 let zero () = Wrapped.unit None
406 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
409 include (Monad.MakeCatch(Trans) : Monad.PLUS with type 'a m := 'a m)
411 module T2(Wrapped : Monad.S2) = struct
412 module Trans = struct
413 include Monad.MakeT2(struct
414 module Wrapped = Wrapped
415 type ('x,'a) m = ('x,'a option) Wrapped.m
416 type ('x,'a) result = ('x,'a option) Wrapped.result
417 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
418 (* code repetition, ugh *)
419 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
420 let bind u f = Wrapped.bind u (fun t -> match t with
422 | None -> Wrapped.unit None)
423 let run u = Wrapped.run u
425 let w = Wrapped.bind u (fun t -> match t with
426 | Some a -> Wrapped.unit a
427 | None -> failwith "no value")
430 let zero () = Wrapped.unit None
431 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
434 include (Monad.MakeCatch2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
439 module List_monad : sig
440 (* declare additional operation, while still hiding implementation of type m *)
441 type 'a result = 'a list
442 type 'a result_exn = 'a
443 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
444 include Monad.PLUS with type 'a m := 'a m
445 val permute : 'a m -> 'a m m
446 val select : 'a m -> ('a * 'a m) m
447 (* ListT transformer *)
448 module T : functor (Wrapped : Monad.S) -> sig
449 type 'a result = 'a list Wrapped.result
450 type 'a result_exn = 'a Wrapped.result_exn
451 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
452 include Monad.PLUS with type 'a m := 'a m
453 val elevate : 'a Wrapped.m -> 'a m
454 (* note that second argument is an 'a list, not the more abstract 'a m *)
455 (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
456 val distribute : ('a -> 'b Wrapped.m) -> 'a list -> 'b m
458 val permute : 'a m -> 'a m m
459 val select : 'a m -> ('a * 'a m) m
462 module T2 : functor (Wrapped : Monad.S2) -> sig
463 type ('x,'a) result = ('x,'a list) Wrapped.result
464 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
465 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
466 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
467 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
468 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
473 type 'a result = 'a list
474 type 'a result_exn = 'a
476 let bind u f = Util.concat_map f u
478 let run_exn u = match u with
479 | [] -> failwith "no values"
481 | many -> failwith "multiple values"
483 let plus = Util.append
485 include Monad.Make(Base)
486 include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
487 (* let either u v = plus u v *)
488 (* insert 3 [1;2] ~~> [[3;1;2]; [1;3;2]; [1;2;3]] *)
490 plus (unit (a :: u)) (match u with
492 | x :: xs -> (insert a xs) >>= fun v -> unit (x :: v)
494 (* permute [1;2;3] ~~> [1;2;3]; [2;1;3]; [2;3;1]; [1;3;2]; [3;1;2]; [3;2;1] *)
495 let rec permute u = match u with
497 | x :: xs -> (permute xs) >>= (fun v -> insert x v)
498 (* select [1;2;3] ~~> [(1,[2;3]); (2,[1;3]), (3;[1;2])] *)
499 let rec select u = match u with
501 | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
503 module T(Wrapped : Monad.S) = struct
504 module Trans = struct
505 (* Wrapped.sequence ms ===
507 Wrapped.bind u (fun x ->
508 Wrapped.bind v (fun xs ->
509 Wrapped.unit (x :: xs)))
510 in Util.fold_right plus1 ms (Wrapped.unit []) *)
511 (* distribute === Wrapped.mapM; copies alist to its image under f *)
512 let distribute f alist = Wrapped.sequence (Util.map f alist)
513 include Monad.MakeT(struct
514 module Wrapped = Wrapped
515 type 'a m = 'a list Wrapped.m
516 type 'a result = 'a list Wrapped.result
517 type 'a result_exn = 'a Wrapped.result_exn
518 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
520 Wrapped.bind u (fun ts ->
521 Wrapped.bind (distribute f ts) (fun tts ->
522 Wrapped.unit (Util.concat tts)))
523 let run u = Wrapped.run u
525 let w = Wrapped.bind u (fun ts -> match ts with
526 | [] -> failwith "no values"
527 | [a] -> Wrapped.unit a
528 | many -> failwith "multiple values"
529 ) in Wrapped.run_exn w
531 let zero () = Wrapped.unit []
533 Wrapped.bind u (fun us ->
534 Wrapped.bind v (fun vs ->
535 Wrapped.unit (base_plus us vs)))
538 include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
540 let permute : 'a m -> 'a m m
541 let select : 'a m -> ('a * 'a m) m
544 module T2(Wrapped : Monad.S2) = struct
545 module Trans = struct
546 let distribute f alist = Wrapped.sequence (Util.map f alist)
547 include Monad.MakeT2(struct
548 module Wrapped = Wrapped
549 type ('x,'a) m = ('x,'a list) Wrapped.m
550 type ('x,'a) result = ('x,'a list) Wrapped.result
551 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
552 (* code repetition, ugh *)
553 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
555 Wrapped.bind u (fun ts ->
556 Wrapped.bind (distribute f ts) (fun tts ->
557 Wrapped.unit (Util.concat tts)))
558 let run u = Wrapped.run u
560 let w = Wrapped.bind u (fun ts -> match ts with
561 | [] -> failwith "no values"
562 | [a] -> Wrapped.unit a
563 | many -> failwith "multiple values"
564 ) in Wrapped.run_exn w
566 let zero () = Wrapped.unit []
568 Wrapped.bind u (fun us ->
569 Wrapped.bind v (fun vs ->
570 Wrapped.unit (base_plus us vs)))
573 include (Monad.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
578 (* must be parameterized on (struct type err = ... end) *)
579 module Error_monad(Err : sig
583 val zero : unit -> err
584 val plus : err -> err -> err
587 (* declare additional operations, while still hiding implementation of type m *)
589 type 'a error = Error of err | Success of 'a
591 type 'a result_exn = 'a
592 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
593 (* include Monad.PLUS with type 'a m := 'a m *)
594 val throw : err -> 'a m
595 val catch : 'a m -> (err -> 'a m) -> 'a m
596 (* ErrorT transformer *)
597 module T : functor (Wrapped : Monad.S) -> sig
598 type 'a result = 'a Wrapped.result
599 type 'a result_exn = 'a Wrapped.result_exn
600 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
601 val elevate : 'a Wrapped.m -> 'a m
602 val throw : err -> 'a m
603 val catch : 'a m -> (err -> 'a m) -> 'a m
605 (* ErrorT transformer when wrapped monad has plus, zero *)
606 module TP : functor (Wrapped : Monad.P) -> sig
607 include module type of T(Wrapped)
608 include Monad.PLUS with type 'a m := 'a m
610 module T2 : functor (Wrapped : Monad.S2) -> sig
611 type ('x,'a) result = ('x,'a) Wrapped.result
612 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
613 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
614 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
615 val throw : err -> ('x,'a) m
616 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
620 type 'a error = Error of err | Success of 'a
624 type 'a result_exn = 'a
625 let unit a = Success a
626 let bind u f = match u with
628 | Error e -> Error e (* input and output may be of different 'a types *)
629 (* TODO: should run refrain from failing? *)
630 let run u = match u with
632 | Error e -> raise (Err.Exc e)
635 let zero () = Error Err.zero
636 let plus u v = match (u, v) with
638 (* to satisfy (Catch) laws, plus u zero = u, even if u = Error _
639 * otherwise, plus (Error _) v = v *)
640 | Error _, _ when v = zero -> u
642 | Error e1, Error e2 when u <> zero -> Error (Err.plus e1 e2)
646 include Monad.Make(Base)
647 (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
648 let throw e = Error e
649 let catch u handler = match u with
651 | Error e -> handler e
652 module T(Wrapped : Monad.S) = struct
653 module Trans = struct
654 module Wrapped = Wrapped
655 type 'a m = 'a error Wrapped.m
656 type 'a result = 'a Wrapped.result
657 type 'a result_exn = 'a Wrapped.result_exn
658 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
659 let bind u f = Wrapped.bind u (fun t -> match t with
661 | Error e -> Wrapped.unit (Error e))
662 (* TODO: should run refrain from failing? *)
664 let w = Wrapped.bind u (fun t -> match t with
665 | Success a -> Wrapped.unit a
666 (* | _ -> Wrapped.fail () *)
667 | Error e -> raise (Err.Exc e))
670 let w = Wrapped.bind u (fun t -> match t with
671 | Success a -> Wrapped.unit a
672 (* | _ -> Wrapped.fail () *)
673 | Error e -> raise (Err.Exc e))
676 include Monad.MakeT(Trans)
677 let throw e = Wrapped.unit (Error e)
678 let catch u handler = Wrapped.bind u (fun t -> match t with
679 | Success _ -> Wrapped.unit t
680 | Error e -> handler e)
682 module TP(Wrapped : Monad.P) = struct
683 module TransP = struct
685 let plus u v = Wrapped.plus u v
686 let zero () = elevate (Wrapped.zero ())
689 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
691 module T2(Wrapped : Monad.S2) = struct
692 module Trans = struct
693 module Wrapped = Wrapped
694 type ('x,'a) m = ('x,'a error) Wrapped.m
695 type ('x,'a) result = ('x,'a) Wrapped.result
696 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
697 (* code repetition, ugh *)
698 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
699 let bind u f = Wrapped.bind u (fun t -> match t with
701 | Error e -> Wrapped.unit (Error e))
703 let w = Wrapped.bind u (fun t -> match t with
704 | Success a -> Wrapped.unit a
705 | Error e -> raise (Err.Exc e))
708 let w = Wrapped.bind u (fun t -> match t with
709 | Success a -> Wrapped.unit a
710 | Error e -> raise (Err.Exc e))
713 include Monad.MakeT2(Trans)
714 let throw e = Wrapped.unit (Error e)
715 let catch u handler = Wrapped.bind u (fun t -> match t with
716 | Success _ -> Wrapped.unit t
717 | Error e -> handler e)
721 (* pre-define common instance of Error_monad *)
722 module Failure = Error_monad(struct
724 exception Exc = Failure
727 let plus s1 s2 = s1 ^ "\n" ^ s2
731 (* must be parameterized on (struct type env = ... end) *)
732 module Reader_monad(Env : sig type env end) : sig
733 (* declare additional operations, while still hiding implementation of type m *)
735 type 'a result = env -> 'a
736 type 'a result_exn = env -> 'a
737 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
739 val asks : (env -> 'a) -> 'a m
740 val local : (env -> env) -> 'a m -> 'a m
741 (* ReaderT transformer *)
742 module T : functor (Wrapped : Monad.S) -> sig
743 type 'a result = env -> 'a Wrapped.result
744 type 'a result_exn = env -> 'a Wrapped.result_exn
745 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
746 val elevate : 'a Wrapped.m -> 'a m
748 val asks : (env -> 'a) -> 'a m
749 val local : (env -> env) -> 'a m -> 'a m
751 (* ReaderT transformer when wrapped monad has plus, zero *)
752 module TP : functor (Wrapped : Monad.P) -> sig
753 include module type of T(Wrapped)
754 include Monad.PLUS with type 'a m := 'a m
756 module T2 : functor (Wrapped : Monad.S2) -> sig
757 type ('x,'a) result = env -> ('x,'a) Wrapped.result
758 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
759 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
760 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
762 val asks : (env -> 'a) -> ('x,'a) m
763 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
765 module TP2 : functor (Wrapped : Monad.P2) -> sig
766 include module type of T2(Wrapped)
767 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
772 type 'a m = env -> 'a
773 type 'a result = env -> 'a
774 type 'a result_exn = env -> 'a
775 let unit a = fun e -> a
776 let bind u f = fun e -> let a = u e in let u' = f a in u' e
777 let run u = fun e -> u e
780 include Monad.Make(Base)
782 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
783 let local modifier u = fun e -> u (modifier e)
784 module T(Wrapped : Monad.S) = struct
785 module Trans = struct
786 module Wrapped = Wrapped
787 type 'a m = env -> 'a Wrapped.m
788 type 'a result = env -> 'a Wrapped.result
789 type 'a result_exn = env -> 'a Wrapped.result_exn
790 let elevate w = fun e -> w
791 let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
792 let run u = fun e -> Wrapped.run (u e)
793 let run_exn u = fun e -> Wrapped.run_exn (u e)
795 include Monad.MakeT(Trans)
796 let ask = fun e -> Wrapped.unit e
797 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
798 let local modifier u = fun e -> u (modifier e)
800 module TP(Wrapped : Monad.P) = struct
801 module TransP = struct
803 let plus u v = fun s -> Wrapped.plus (u s) (v s)
804 let zero () = elevate (Wrapped.zero ())
805 let asks selector = ask >>= (fun e ->
806 try unit (selector e)
807 with Not_found -> fun e -> Wrapped.zero ())
810 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
812 module T2(Wrapped : Monad.S2) = struct
813 module Trans = struct
814 module Wrapped = Wrapped
815 type ('x,'a) m = env -> ('x,'a) Wrapped.m
816 type ('x,'a) result = env -> ('x,'a) Wrapped.result
817 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
818 (* code repetition, ugh *)
819 let elevate w = fun e -> w
820 let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
821 let run u = fun e -> Wrapped.run (u e)
822 let run_exn u = fun e -> Wrapped.run_exn (u e)
824 include Monad.MakeT2(Trans)
825 let ask = fun e -> Wrapped.unit e
826 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
827 let local modifier u = fun e -> u (modifier e)
829 module TP2(Wrapped : Monad.P2) = struct
830 module TransP = struct
831 (* code repetition, ugh *)
833 let plus u v = fun s -> Wrapped.plus (u s) (v s)
834 let zero () = elevate (Wrapped.zero ())
835 let asks selector = ask >>= (fun e ->
836 try unit (selector e)
837 with Not_found -> fun e -> Wrapped.zero ())
840 include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
845 (* must be parameterized on (struct type store = ... end) *)
846 module State_monad(Store : sig type store end) : sig
847 (* declare additional operations, while still hiding implementation of type m *)
848 type store = Store.store
849 type 'a result = store -> 'a * store
850 type 'a result_exn = store -> 'a
851 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
853 val gets : (store -> 'a) -> 'a m
854 val put : store -> unit m
855 val puts : (store -> store) -> unit m
856 (* StateT transformer *)
857 module T : functor (Wrapped : Monad.S) -> sig
858 type 'a result = store -> ('a * store) Wrapped.result
859 type 'a result_exn = store -> 'a Wrapped.result_exn
860 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
861 val elevate : 'a Wrapped.m -> 'a m
863 val gets : (store -> 'a) -> 'a m
864 val put : store -> unit m
865 val puts : (store -> store) -> unit m
867 (* StateT transformer when wrapped monad has plus, zero *)
868 module TP : functor (Wrapped : Monad.P) -> sig
869 include module type of T(Wrapped)
870 include Monad.PLUS with type 'a m := 'a m
872 module T2 : functor (Wrapped : Monad.S2) -> sig
873 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
874 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
875 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
876 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
877 val get : ('x,store) m
878 val gets : (store -> 'a) -> ('x,'a) m
879 val put : store -> ('x,unit) m
880 val puts : (store -> store) -> ('x,unit) m
882 module TP2 : functor (Wrapped : Monad.P2) -> sig
883 include module type of T2(Wrapped)
884 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
887 type store = Store.store
889 type 'a m = store -> 'a * store
890 type 'a result = store -> 'a * store
891 type 'a result_exn = store -> 'a
892 let unit a = fun s -> (a, s)
893 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
894 let run u = fun s -> (u s)
895 let run_exn u = fun s -> fst (u s)
897 include Monad.Make(Base)
898 let get = fun s -> (s, s)
899 let gets viewer = fun s -> (viewer s, s) (* may fail *)
900 let put s = fun _ -> ((), s)
901 let puts modifier = fun s -> ((), modifier s)
902 module T(Wrapped : Monad.S) = struct
903 module Trans = struct
904 module Wrapped = Wrapped
905 type 'a m = store -> ('a * store) Wrapped.m
906 type 'a result = store -> ('a * store) Wrapped.result
907 type 'a result_exn = store -> 'a Wrapped.result_exn
908 let elevate w = fun s ->
909 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
910 let bind u f = fun s ->
911 Wrapped.bind (u s) (fun (a, s') -> f a s')
912 let run u = fun s -> Wrapped.run (u s)
913 let run_exn u = fun s ->
914 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
917 include Monad.MakeT(Trans)
918 let get = fun s -> Wrapped.unit (s, s)
919 let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
920 let put s = fun _ -> Wrapped.unit ((), s)
921 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
923 module TP(Wrapped : Monad.P) = struct
924 module TransP = struct
926 let plus u v = fun s -> Wrapped.plus (u s) (v s)
927 let zero () = elevate (Wrapped.zero ())
929 let gets viewer = fun s ->
930 try Wrapped.unit (viewer s, s)
931 with Not_found -> Wrapped.zero ()
933 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
935 module T2(Wrapped : Monad.S2) = struct
936 module Trans = struct
937 module Wrapped = Wrapped
938 type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
939 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
940 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
941 (* code repetition, ugh *)
942 let elevate w = fun s ->
943 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
944 let bind u f = fun s ->
945 Wrapped.bind (u s) (fun (a, s') -> f a s')
946 let run u = fun s -> Wrapped.run (u s)
947 let run_exn u = fun s ->
948 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
951 include Monad.MakeT2(Trans)
952 let get = fun s -> Wrapped.unit (s, s)
953 let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
954 let put s = fun _ -> Wrapped.unit ((), s)
955 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
957 module TP2(Wrapped : Monad.P2) = struct
958 module TransP = struct
960 let plus u v = fun s -> Wrapped.plus (u s) (v s)
961 let zero () = elevate (Wrapped.zero ())
963 let gets viewer = fun s ->
964 try Wrapped.unit (viewer s, s)
965 with Not_found -> Wrapped.zero ()
967 include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
971 (* State monad with different interface (structured store) *)
972 module Ref_monad(V : sig
978 type 'a result_exn = 'a
979 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
980 val newref : value -> ref m
981 val deref : ref -> value m
982 val change : ref -> value -> unit m
983 (* RefT transformer *)
984 module T : functor (Wrapped : Monad.S) -> sig
985 type 'a result = 'a Wrapped.result
986 type 'a result_exn = 'a Wrapped.result_exn
987 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
988 val elevate : 'a Wrapped.m -> 'a m
989 val newref : value -> ref m
990 val deref : ref -> value m
991 val change : ref -> value -> unit m
993 (* RefT transformer when wrapped monad has plus, zero *)
994 module TP : functor (Wrapped : Monad.P) -> sig
995 include module type of T(Wrapped)
996 include Monad.PLUS with type 'a m := 'a m
998 module T2 : functor (Wrapped : Monad.S2) -> sig
999 type ('x,'a) result = ('x,'a) Wrapped.result
1000 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
1001 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1002 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
1003 val newref : value -> ('x,ref) m
1004 val deref : ref -> ('x,value) m
1005 val change : ref -> value -> ('x,unit) m
1007 module TP2 : functor (Wrapped : Monad.P2) -> sig
1008 include module type of T2(Wrapped)
1009 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
1013 type value = V.value
1014 module D = Map.Make(struct type t = ref let compare = compare end)
1015 type dict = { next: ref; tree : value D.t }
1016 let empty = { next = 0; tree = D.empty }
1017 let alloc (value : value) (d : dict) =
1018 (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
1019 let read (key : ref) (d : dict) =
1021 let write (key : ref) (value : value) (d : dict) =
1022 { next = d.next; tree = D.add key value d.tree }
1023 module Base = struct
1024 type 'a m = dict -> 'a * dict
1026 type 'a result_exn = 'a
1027 let unit a = fun s -> (a, s)
1028 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
1029 let run u = fst (u empty)
1032 include Monad.Make(Base)
1033 let newref value = fun s -> alloc value s
1034 let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
1035 let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
1036 module T(Wrapped : Monad.S) = struct
1037 module Trans = struct
1038 module Wrapped = Wrapped
1039 type 'a m = dict -> ('a * dict) Wrapped.m
1040 type 'a result = 'a Wrapped.result
1041 type 'a result_exn = 'a Wrapped.result_exn
1042 let elevate w = fun s ->
1043 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
1044 let bind u f = fun s ->
1045 Wrapped.bind (u s) (fun (a, s') -> f a s')
1047 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1050 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1051 in Wrapped.run_exn w
1053 include Monad.MakeT(Trans)
1054 let newref value = fun s -> Wrapped.unit (alloc value s)
1055 let deref key = fun s -> Wrapped.unit (read key s, s)
1056 let change key value = fun s -> Wrapped.unit ((), write key value s)
1058 module TP(Wrapped : Monad.P) = struct
1059 module TransP = struct
1061 let plus u v = fun s -> Wrapped.plus (u s) (v s)
1062 let zero () = elevate (Wrapped.zero ())
1065 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
1067 module T2(Wrapped : Monad.S2) = struct
1068 module Trans = struct
1069 module Wrapped = Wrapped
1070 type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
1071 type ('x,'a) result = ('x,'a) Wrapped.result
1072 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
1073 (* code repetition, ugh *)
1074 let elevate w = fun s ->
1075 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
1076 let bind u f = fun s ->
1077 Wrapped.bind (u s) (fun (a, s') -> f a s')
1079 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1082 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1083 in Wrapped.run_exn w
1085 include Monad.MakeT2(Trans)
1086 let newref value = fun s -> Wrapped.unit (alloc value s)
1087 let deref key = fun s -> Wrapped.unit (read key s, s)
1088 let change key value = fun s -> Wrapped.unit ((), write key value s)
1090 module TP2(Wrapped : Monad.P2) = struct
1091 module TransP = struct
1093 let plus u v = fun s -> Wrapped.plus (u s) (v s)
1094 let zero () = elevate (Wrapped.zero ())
1097 include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
1102 (* must be parameterized on (struct type log = ... end) *)
1103 module Writer_monad(Log : sig
1106 val plus : log -> log -> log
1108 (* declare additional operations, while still hiding implementation of type m *)
1110 type 'a result = 'a * log
1111 type 'a result_exn = 'a * log
1112 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1113 val tell : log -> unit m
1114 val listen : 'a m -> ('a * log) m
1115 val listens : (log -> 'b) -> 'a m -> ('a * 'b) m
1116 (* val pass : ('a * (log -> log)) m -> 'a m *)
1117 val censor : (log -> log) -> 'a m -> 'a m
1120 module Base = struct
1121 type 'a m = 'a * log
1122 type 'a result = 'a * log
1123 type 'a result_exn = 'a * log
1124 let unit a = (a, Log.zero)
1125 let bind (a, w) f = let (a', w') = f a in (a', Log.plus w w')
1129 include Monad.Make(Base)
1130 let tell entries = ((), entries) (* add entries to log *)
1131 let listen (a, w) = ((a, w), w)
1132 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
1133 let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
1134 let censor f u = pass (u >>= fun a -> unit (a, f))
1137 (* pre-define simple Writer *)
1138 module Writer1 = Writer_monad(struct
1141 let plus s1 s2 = s1 ^ "\n" ^ s2
1144 (* slightly more efficient Writer *)
1145 module Writer2 = struct
1146 include Writer_monad(struct
1147 type log = string list
1149 let plus w w' = Util.append w' w
1151 let tell_string s = tell [s]
1152 let tell entries = tell (Util.reverse entries)
1153 let run u = let (a, w) = run u in (a, Util.reverse w)
1158 module IO_monad : sig
1159 (* declare additional operation, while still hiding implementation of type m *)
1161 type 'a result_exn = 'a
1162 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1163 val printf : ('a, unit, string, unit m) format4 -> 'a
1164 val print_string : string -> unit m
1165 val print_int : int -> unit m
1166 val print_hex : int -> unit m
1167 val print_bool : bool -> unit m
1169 module Base = struct
1170 type 'a m = { run : unit -> unit; value : 'a }
1172 type 'a result_exn = 'a
1173 let unit a = { run = (fun () -> ()); value = a }
1174 let bind (a : 'a m) (f: 'a -> 'b m) : 'b m =
1175 let fres = f a.value in
1176 { run = (fun () -> a.run (); fres.run ()); value = fres.value }
1177 let run a = let () = a.run () in a.value
1180 include Monad.Make(Base)
1182 Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
1183 let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
1184 let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
1185 let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
1186 let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
1190 module Continuation_monad : sig
1191 (* expose only the implementation of type `('r,'a) result` *)
1193 type 'a result = 'a m
1194 type 'a result_exn = 'a m
1195 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn and type 'a m := 'a m
1196 (* val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m *)
1197 (* misses that the answer types of all the cont's must be the same *)
1198 val callcc : (('a -> 'b m) -> 'a m) -> 'a m
1199 (* val reset : ('a,'a) m -> ('r,'a) m *)
1200 val reset : 'a m -> 'a m
1201 (* val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m *)
1202 (* misses that the answer types of second and third continuations must be b *)
1203 val shift : (('a -> 'b m) -> 'b m) -> 'a m
1204 (* overwrite the run declaration in S, because I can't declare 'a result =
1205 * this polymorphic type (complains that 'r is unbound *)
1206 val runk : 'a m -> ('a -> 'r) -> 'r
1207 val run0 : 'a m -> 'a
1210 module Base = struct
1211 (* 'r is result type of whole computation *)
1212 type 'a m = { cont : 'r. ('a -> 'r) -> 'r }
1213 type 'a result = 'a m
1214 type 'a result_exn = 'a m
1216 let cont : 'r. ('a -> 'r) -> 'r =
1220 let cont : 'r. ('a -> 'r) -> 'r =
1221 fun k -> u.cont (fun a -> (f a).cont k)
1223 let run (u : 'a m) : 'a result = u
1224 let run_exn (u : 'a m) : 'a result_exn = u
1226 let cont : 'r. ('a -> 'r) -> 'r =
1227 (* Can't figure out how to make the type polymorphic enough
1228 * to satisfy the OCaml type-checker (it's ('a -> 'r) -> 'r
1229 * instead of 'r. ('a -> 'r) -> 'r); so we have to fudge
1230 * with Obj.magic... which tells OCaml's type checker to
1231 * relax, the supplied value has whatever type the context
1232 * needs it to have. *)
1234 let usek a = { cont = Obj.magic (fun _ -> k a) }
1237 let reset u = unit (u.cont id)
1238 let shift (f : ('a -> 'b m) -> 'b m) : 'a m =
1240 (f (fun a -> unit (k a))).cont id
1241 in { cont = Obj.magic cont }
1242 let runk u k = (u.cont : ('a -> 'r) -> 'r) k
1243 let run0 u = runk u id
1245 include Monad.Make(Base)
1246 let callcc = Base.callcc
1247 let reset = Base.reset
1248 let shift = Base.shift
1249 let runk = Base.runk
1250 let run0 = Base.run0
1254 (* This two-type parameter version works without Obj.magic *)
1255 module Continuation_monad : sig
1256 (* expose only the implementation of type `('r,'a) result` *)
1258 type ('r,'a) result = ('r,'a) m
1259 type ('r,'a) result_exn = ('a -> 'r) -> 'r
1260 include Monad.S2 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
1261 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
1262 val reset : ('a,'a) m -> ('r,'a) m
1263 val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
1264 (* val abort : ('a,'a) m -> ('a,'b) m *)
1265 val abort : 'a -> ('a,'b) m
1266 val run0 : ('a,'a) m -> 'a
1269 module Base = struct
1270 (* 'r is result type of whole computation *)
1271 type ('r,'a) m = ('a -> 'r) -> 'r
1272 type ('r,'a) result = ('a -> 'r) -> 'r
1273 type ('r,'a) result_exn = ('r,'a) result
1274 let unit a = (fun k -> k a)
1275 let bind u f = (fun k -> (u) (fun a -> (f a) k))
1279 include Monad.Make2(Base)
1280 let callcc f = (fun k ->
1281 let usek a = (fun _ -> k a)
1284 val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
1285 val throw : ('a -> 'r) -> 'a -> ('r,'b) m
1286 let callcc f = fun k -> f k k
1287 let throw k a = fun _ -> k a
1290 (* from http://www.haskell.org/haskellwiki/MonadCont_done_right
1292 * reset :: (Monad m) => ContT a m a -> ContT r m a
1293 * reset e = ContT $ \k -> runContT e return >>= k
1295 * shift :: (Monad m) => ((a -> ContT r m b) -> ContT b m b) -> ContT b m a
1296 * shift e = ContT $ \k ->
1297 * runContT (e $ \v -> ContT $ \c -> k v >>= c) return *)
1298 let reset u = unit ((u) id)
1299 let shift f = (fun k -> (f (fun a -> unit (k a))) id)
1300 (* let abort a = shift (fun _ -> a) *)
1301 let abort a = shift (fun _ -> unit a)
1302 let run0 (u : ('a,'a) m) = (u) id
1308 * (define (example n)
1309 * (let ([u (let/cc k ; type int -> int pair
1310 * (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
1311 * (+ 1 (car v))))]) ; int
1312 * (cons u 0))) ; int pair
1313 * ; (example 10) ~~> '(111 . 0)
1314 * ; (example -10) ~~> '(0 . 0)
1317 * let example n : (int * int) =
1318 * Continuation_monad.(let u = callcc (fun k ->
1319 * (if n < 0 then k 0 else unit [n + 100])
1320 * (* all of the following is skipped by k 0; the end type int is k's input type *)
1321 * >>= fun [x] -> unit (x + 1)
1323 * (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1324 * >>= fun x -> unit (x, 0)
1328 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1329 * let example1 () : int =
1330 * Continuation_monad.(let v = reset (
1331 * let u = shift (fun k -> unit (10 + 1))
1332 * in u >>= fun x -> unit (100 + x)
1333 * ) in let w = v >>= fun x -> unit (1000 + x)
1336 * (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1338 * Continuation_monad.(let v = reset (
1339 * let u = shift (fun k -> k (10 :: [1]))
1340 * in u >>= fun x -> unit (100 :: x)
1341 * ) in let w = v >>= fun x -> unit (1000 :: x)
1344 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1346 * Continuation_monad.(let v = reset (
1347 * let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1348 * in u >>= fun x -> unit (100 :: x)
1349 * ) in let w = v >>= fun x -> unit (1000 :: x)
1352 * (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1353 * (* not sure if this example can be typed without a sum-type *)
1355 * (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1356 * let example5 () : int =
1357 * Continuation_monad.(let v = reset (
1358 * let u = shift (fun k -> k 1 >>= fun x -> k x)
1359 * in u >>= fun x -> unit (10 + x)
1360 * ) in let w = v >>= fun x -> unit (100 + x)
1366 module Leaf_monad : sig
1367 (* We implement the type as `'a tree option` because it has a natural`plus`,
1368 * and the rest of the library expects that `plus` and `zero` will come together. *)
1369 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1370 type 'a result = 'a tree option
1371 type 'a result_exn = 'a tree
1372 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1373 include Monad.PLUS with type 'a m := 'a m
1374 (* LeafT transformer *)
1375 module T : functor (Wrapped : Monad.S) -> sig
1376 type 'a result = 'a tree option Wrapped.result
1377 type 'a result_exn = 'a tree Wrapped.result_exn
1378 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1379 include Monad.PLUS with type 'a m := 'a m
1380 val elevate : 'a Wrapped.m -> 'a m
1381 (* note that second argument is an 'a tree?, not the more abstract 'a m *)
1382 (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
1383 val distribute : ('a -> 'b Wrapped.m) -> 'a tree option -> 'b m
1385 module T2 : functor (Wrapped : Monad.S2) -> sig
1386 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1387 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1388 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1389 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
1390 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
1391 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
1394 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1395 (* uses supplied plus and zero to copy t to its image under f *)
1396 let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
1398 | Some ts -> let rec loop ts = (match ts with
1401 (* recursive application of f may delete a branch *)
1402 plus (loop l) (loop r)
1404 module Base = struct
1405 type 'a m = 'a tree option
1406 type 'a result = 'a tree option
1407 type 'a result_exn = 'a tree
1408 let unit a = Some (Leaf a)
1410 let plus u v = match (u, v) with
1413 | Some us, Some vs -> Some (Node (us, vs))
1414 let bind u f = mapT f u zero plus
1416 let run_exn u = match u with
1417 | None -> failwith "no values"
1419 | Some (Leaf a) -> a
1420 | many -> failwith "multiple values"
1424 include Monad.Make(Base)
1425 include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
1426 let base_plus = plus
1427 let base_lift = lift
1428 module T(Wrapped : Monad.S) = struct
1429 module Trans = struct
1430 let zero () = Wrapped.unit None
1432 Wrapped.bind u (fun us ->
1433 Wrapped.bind v (fun vs ->
1434 Wrapped.unit (base_plus us vs)))
1435 include Monad.MakeT(struct
1436 module Wrapped = Wrapped
1437 type 'a m = 'a tree option Wrapped.m
1438 type 'a result = 'a tree option Wrapped.result
1439 type 'a result_exn = 'a tree Wrapped.result_exn
1440 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1441 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1442 let run u = Wrapped.run u
1444 let w = Wrapped.bind u (fun t -> match t with
1445 | None -> failwith "no values"
1446 | Some ts -> Wrapped.unit ts)
1447 in Wrapped.run_exn w
1451 include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
1452 (* let distribute f t = mapT (fun a -> a) (base_lift (fun a -> elevate (f a)) t) zero plus *)
1453 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1455 module T2(Wrapped : Monad.S2) = struct
1456 module Trans = struct
1457 let zero () = Wrapped.unit None
1459 Wrapped.bind u (fun us ->
1460 Wrapped.bind v (fun vs ->
1461 Wrapped.unit (base_plus us vs)))
1462 include Monad.MakeT2(struct
1463 module Wrapped = Wrapped
1464 type ('x,'a) m = ('x,'a tree option) Wrapped.m
1465 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1466 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1467 (* code repetition, ugh *)
1468 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1469 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1470 let run u = Wrapped.run u
1472 let w = Wrapped.bind u (fun t -> match t with
1473 | None -> failwith "no values"
1474 | Some ts -> Wrapped.unit ts)
1475 in Wrapped.run_exn w
1479 include (Monad.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
1480 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1485 module L = List_monad;;
1486 module R = Reader_monad(struct type env = int -> int end);;
1487 module S = State_monad(struct type store = int end);;
1488 module T = Leaf_monad;;
1489 module LR = L.T(R);;
1490 module LS = L.T(S);;
1491 module TL = T.T(L);;
1492 module TR = T.T(R);;
1493 module TS = T.T(S);;
1494 module C = Continuation_monad
1495 module TC = T.T2(C);;
1498 print_endline "=== test Leaf(...).distribute ==================";;
1500 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))));;
1502 let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
1505 - : int T.tree option * S.store =
1508 (T.Node (T.Leaf 2, T.Leaf 3),
1509 T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
1513 let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
1516 - : (int * S.store) T.tree option * S.store =
1519 (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
1520 T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
1524 let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
1525 TR.run_exn tr (fun i -> i+i);;
1527 - : int T.tree option =
1530 (T.Node (T.Leaf 4, T.Leaf 6),
1531 T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
1534 let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
1537 - : (int * int) TL.result =
1540 (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
1541 T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
1544 let l2 = [1;2;3;4;5];;
1545 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))));;
1547 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);;
1548 (* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
1550 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);;
1555 (T.Node (T.Leaf 10, T.Leaf 11),
1558 (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
1559 T.Node (T.Leaf 40, T.Leaf 41)),
1560 T.Node (T.Leaf 50, T.Leaf 51))))
1563 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;;
1565 - : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
1568 print_endline "=== test Leaf(Continuation).distribute ==================";;
1570 let id : 'z. 'z -> 'z = fun x -> x
1572 let example n : (int * int) =
1573 Continuation_monad.(let u = callcc (fun k ->
1574 (if n < 0 then k 0 else unit [n + 100])
1575 (* all of the following is skipped by k 0; the end type int is k's input type *)
1576 >>= fun [x] -> unit (x + 1)
1578 (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1579 >>= fun x -> unit (x, 0)
1583 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1584 let example1 () : int =
1585 Continuation_monad.(let v = reset (
1586 let u = shift (fun k -> unit (10 + 1))
1587 in u >>= fun x -> unit (100 + x)
1588 ) in let w = v >>= fun x -> unit (1000 + x)
1591 (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1593 Continuation_monad.(let v = reset (
1594 let u = shift (fun k -> k (10 :: [1]))
1595 in u >>= fun x -> unit (100 :: x)
1596 ) in let w = v >>= fun x -> unit (1000 :: x)
1599 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1601 Continuation_monad.(let v = reset (
1602 let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1603 in u >>= fun x -> unit (100 :: x)
1604 ) in let w = v >>= fun x -> unit (1000 :: x)
1607 (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1608 (* not sure if this example can be typed without a sum-type *)
1610 (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1611 let example5 () : int =
1612 Continuation_monad.(let v = reset (
1613 let u = shift (fun k -> k 1 >>= k)
1614 in u >>= fun x -> unit (10 + x)
1615 ) in let w = v >>= fun x -> unit (100 + x)
1620 print_endline "=== test bare Continuation ============";;
1622 (1011, 1111, 1111, 121);;
1623 (example1(), example2(), example3(), example5());;
1625 (example ~+10, example ~-10);;
1628 C.run_exn TC.(run (distribute df t1)) ic;;
1633 let initial_continuation = fun t -> t in
1634 TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
1639 (* count leaves, using continuation *)
1640 let initial_continuation = fun t -> 0 in
1641 TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
1644 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
1647 (* convert tree to list of leaves *)
1648 let initial_continuation = fun t -> [] in
1649 TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
1652 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
1655 (* square each leaf using continuation *)
1656 let initial_continuation = fun t -> t in
1657 TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
1660 testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
1664 (* replace leaves with list, using continuation *)
1665 let initial_continuation = fun t -> t in
1666 TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
1669 testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;
1671 print_endline "=== pa_monad's Continuation Tests ============";;
1673 (1, 5 = C.(run0 (unit 1 >>= fun x -> unit (x+4))) );;
1674 (2, 9 = C.(run0 (reset (unit 5 >>= fun x -> unit (x+4)))) );;
1675 (3, 9 = C.(run0 (reset (abort 5 >>= fun y -> unit (y+6)) >>= fun x -> unit (x+4))) );;
1676 (4, 9 = C.(run0 (reset (reset (abort 5 >>= fun y -> unit (y+6))) >>= fun x -> unit (x+4))) );;
1678 let c = reset(abort 5 >>= fun y -> unit (y+6))
1679 in reset(c >>= fun v1 -> abort 7 >>= fun v2 -> unit (v2+10) ) >>= fun x -> unit (x+20))) );;
1681 (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))) );;
1683 (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))) );;
1685 (12, ["a"] = C.(run0 (reset (shift (fun f -> f [] >>= fun t -> unit ("a"::t) ) >>= fun xv -> shift (fun _ -> unit xv)))) );;
1688 (0, 15 = C.(run0 (let f k = k 10 >>= fun v-> unit (v+100) in reset (callcc f >>= fun v -> unit (v+5)))) );;