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
590 type 'a result = 'a error
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 error 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 type 'a result = 'a Wrapped.result
608 type 'a result_exn = 'a Wrapped.result_exn
609 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
610 val elevate : 'a Wrapped.m -> 'a m
611 val throw : err -> 'a m
612 val catch : 'a m -> (err -> 'a m) -> 'a m
613 include Monad.PLUS with type 'a m := 'a m
615 module T2 : functor (Wrapped : Monad.S2) -> sig
616 type ('x,'a) result = ('x,'a error) Wrapped.result
617 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
618 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
619 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
620 val throw : err -> ('x,'a) m
621 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
623 module TP2 : functor (Wrapped : Monad.P2) -> sig
624 type ('x,'a) result = ('x,'a) Wrapped.result
625 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
626 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
627 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
628 val throw : err -> ('x,'a) m
629 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
630 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
634 type 'a error = Error of err | Success of 'a
637 type 'a result = 'a error
638 type 'a result_exn = 'a
639 let unit a = Success a
640 let bind u f = match u with
642 | Error e -> Error e (* input and output may be of different 'a types *)
644 let run_exn u = match u with
646 | Error e -> raise (Err.Exc e)
648 let zero () = Error Err.zero
649 let plus u v = match (u, v) with
651 (* to satisfy (Catch) laws, plus u zero = u, even if u = Error _
652 * otherwise, plus (Error _) v = v *)
653 | Error _, _ when v = zero -> u
655 | Error e1, Error e2 when u <> zero -> Error (Err.plus e1 e2)
659 include Monad.Make(Base)
660 (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
661 let throw e = Error e
662 let catch u handler = match u with
664 | Error e -> handler e
665 module T(Wrapped : Monad.S) = struct
666 module Trans = struct
667 module Wrapped = Wrapped
668 type 'a m = 'a error Wrapped.m
669 type 'a result = 'a error Wrapped.result
670 type 'a result_exn = 'a Wrapped.result_exn
671 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
672 let bind u f = Wrapped.bind u (fun t -> match t with
674 | Error e -> Wrapped.unit (Error e))
675 let run u = Wrapped.run u
677 let w = Wrapped.bind u (fun t -> match t with
678 | Success a -> Wrapped.unit a
679 (* | _ -> Wrapped.fail () *)
680 | Error e -> raise (Err.Exc e))
683 include Monad.MakeT(Trans)
684 let throw e = Wrapped.unit (Error e)
685 let catch u handler = Wrapped.bind u (fun t -> match t with
686 | Success _ -> Wrapped.unit t
687 | Error e -> handler e)
689 module TP(Wrapped : Monad.P) = struct
690 (* code repetition, ugh *)
691 module TransP = struct
692 include Monad.MakeT(struct
693 module Wrapped = Wrapped
694 type 'a m = 'a error Wrapped.m
695 type 'a result = 'a Wrapped.result
696 type 'a result_exn = 'a Wrapped.result_exn
697 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
698 let bind u f = Wrapped.bind u (fun t -> match t with
700 | Error e -> Wrapped.unit (Error e))
702 let w = Wrapped.bind u (fun t -> match t with
703 | Success a -> Wrapped.unit a
704 | Error e -> Wrapped.zero ())
707 let w = Wrapped.bind u (fun t -> match t with
708 | Success a -> Wrapped.unit a
709 (* | _ -> Wrapped.fail () *)
710 | Error e -> raise (Err.Exc e))
713 let throw e = Wrapped.unit (Error e)
714 let catch u handler = Wrapped.bind u (fun t -> match t with
715 | Success _ -> Wrapped.unit t
716 | Error e -> handler e)
717 let plus u v = Wrapped.plus u v
718 let zero () = elevate (Wrapped.zero ())
721 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
723 module T2(Wrapped : Monad.S2) = struct
724 module Trans = struct
725 module Wrapped = Wrapped
726 type ('x,'a) m = ('x,'a error) Wrapped.m
727 type ('x,'a) result = ('x,'a error) Wrapped.result
728 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
729 (* code repetition, ugh *)
730 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
731 let bind u f = Wrapped.bind u (fun t -> match t with
733 | Error e -> Wrapped.unit (Error e))
734 let run u = Wrapped.run u
736 let w = Wrapped.bind u (fun t -> match t with
737 | Success a -> Wrapped.unit a
738 | Error e -> raise (Err.Exc e))
741 include Monad.MakeT2(Trans)
742 let throw e = Wrapped.unit (Error e)
743 let catch u handler = Wrapped.bind u (fun t -> match t with
744 | Success _ -> Wrapped.unit t
745 | Error e -> handler e)
747 module TP2(Wrapped : Monad.P2) = struct
748 (* code repetition, ugh *)
749 module TransP = struct
750 include Monad.MakeT2(struct
751 module Wrapped = Wrapped
752 type ('x,'a) m = ('x,'a error) Wrapped.m
753 type ('x,'a) result = ('x,'a) Wrapped.result
754 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
755 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
756 let bind u f = Wrapped.bind u (fun t -> match t with
758 | Error e -> Wrapped.unit (Error e))
760 let w = Wrapped.bind u (fun t -> match t with
761 | Success a -> Wrapped.unit a
762 | Error e -> Wrapped.zero ())
765 let w = Wrapped.bind u (fun t -> match t with
766 | Success a -> Wrapped.unit a
767 (* | _ -> Wrapped.fail () *)
768 | Error e -> raise (Err.Exc e))
771 let throw e = Wrapped.unit (Error e)
772 let catch u handler = Wrapped.bind u (fun t -> match t with
773 | Success _ -> Wrapped.unit t
774 | Error e -> handler e)
775 let plus u v = Wrapped.plus u v
776 let zero () = elevate (Wrapped.zero ())
779 include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
783 (* pre-define common instance of Error_monad *)
784 module Failure = Error_monad(struct
786 exception Exc = Failure
789 let plus s1 s2 = s1 ^ "\n" ^ s2
794 # EL.(run( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
795 - : int EL.result = [Failure.Error "bye"; Failure.Success 30]
796 # LE.(run( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
797 - : int LE.result = Failure.Error "bye"
798 # EL.(run_exn( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
799 Exception: Failure "bye".
800 # LE.(run_exn( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
801 Exception: Failure "bye".
803 # ES.(run( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
804 - : int Failure.error * S.store = (Failure.Error "bye", 1)
805 # SE.(run( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
806 - : (int * S.store) Failure.result = Failure.Error "bye"
807 # ES.(run_exn( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
808 Exception: Failure "bye".
809 # SE.(run_exn( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
810 Exception: Failure "bye".
814 (* must be parameterized on (struct type env = ... end) *)
815 module Reader_monad(Env : sig type env end) : sig
816 (* declare additional operations, while still hiding implementation of type m *)
818 type 'a result = env -> 'a
819 type 'a result_exn = env -> 'a
820 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
822 val asks : (env -> 'a) -> 'a m
823 val local : (env -> env) -> 'a m -> 'a m
824 (* ReaderT transformer *)
825 module T : functor (Wrapped : Monad.S) -> sig
826 type 'a result = env -> 'a Wrapped.result
827 type 'a result_exn = env -> 'a Wrapped.result_exn
828 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
829 val elevate : 'a Wrapped.m -> 'a m
831 val asks : (env -> 'a) -> 'a m
832 val local : (env -> env) -> 'a m -> 'a m
834 (* ReaderT transformer when wrapped monad has plus, zero *)
835 module TP : functor (Wrapped : Monad.P) -> sig
836 include module type of T(Wrapped)
837 include Monad.PLUS with type 'a m := 'a m
839 module T2 : functor (Wrapped : Monad.S2) -> sig
840 type ('x,'a) result = env -> ('x,'a) Wrapped.result
841 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
842 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
843 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
845 val asks : (env -> 'a) -> ('x,'a) m
846 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
848 module TP2 : functor (Wrapped : Monad.P2) -> sig
849 include module type of T2(Wrapped)
850 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
855 type 'a m = env -> 'a
856 type 'a result = env -> 'a
857 type 'a result_exn = env -> 'a
858 let unit a = fun e -> a
859 let bind u f = fun e -> let a = u e in let u' = f a in u' e
860 let run u = fun e -> u e
863 include Monad.Make(Base)
865 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
866 let local modifier u = fun e -> u (modifier e)
867 module T(Wrapped : Monad.S) = struct
868 module Trans = struct
869 module Wrapped = Wrapped
870 type 'a m = env -> 'a Wrapped.m
871 type 'a result = env -> 'a Wrapped.result
872 type 'a result_exn = env -> 'a Wrapped.result_exn
873 let elevate w = fun e -> w
874 let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
875 let run u = fun e -> Wrapped.run (u e)
876 let run_exn u = fun e -> Wrapped.run_exn (u e)
878 include Monad.MakeT(Trans)
879 let ask = fun e -> Wrapped.unit e
880 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
881 let local modifier u = fun e -> u (modifier e)
883 module TP(Wrapped : Monad.P) = struct
884 module TransP = struct
886 let plus u v = fun s -> Wrapped.plus (u s) (v s)
887 let zero () = elevate (Wrapped.zero ())
888 let asks selector = ask >>= (fun e ->
889 try unit (selector e)
890 with Not_found -> fun e -> Wrapped.zero ())
893 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
895 module T2(Wrapped : Monad.S2) = struct
896 module Trans = struct
897 module Wrapped = Wrapped
898 type ('x,'a) m = env -> ('x,'a) Wrapped.m
899 type ('x,'a) result = env -> ('x,'a) Wrapped.result
900 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
901 (* code repetition, ugh *)
902 let elevate w = fun e -> w
903 let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
904 let run u = fun e -> Wrapped.run (u e)
905 let run_exn u = fun e -> Wrapped.run_exn (u e)
907 include Monad.MakeT2(Trans)
908 let ask = fun e -> Wrapped.unit e
909 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
910 let local modifier u = fun e -> u (modifier e)
912 module TP2(Wrapped : Monad.P2) = struct
913 module TransP = struct
915 (* code repetition, ugh *)
916 let plus u v = fun s -> Wrapped.plus (u s) (v s)
917 let zero () = elevate (Wrapped.zero ())
918 let asks selector = ask >>= (fun e ->
919 try unit (selector e)
920 with Not_found -> fun e -> Wrapped.zero ())
923 include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
928 (* must be parameterized on (struct type store = ... end) *)
929 module State_monad(Store : sig type store end) : sig
930 (* declare additional operations, while still hiding implementation of type m *)
931 type store = Store.store
932 type 'a result = store -> 'a * store
933 type 'a result_exn = store -> 'a
934 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
936 val gets : (store -> 'a) -> 'a m
937 val put : store -> unit m
938 val puts : (store -> store) -> unit m
939 (* StateT transformer *)
940 module T : functor (Wrapped : Monad.S) -> sig
941 type 'a result = store -> ('a * store) Wrapped.result
942 type 'a result_exn = store -> 'a Wrapped.result_exn
943 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
944 val elevate : 'a Wrapped.m -> 'a m
946 val gets : (store -> 'a) -> 'a m
947 val put : store -> unit m
948 val puts : (store -> store) -> unit m
950 (* StateT transformer when wrapped monad has plus, zero *)
951 module TP : functor (Wrapped : Monad.P) -> sig
952 include module type of T(Wrapped)
953 include Monad.PLUS with type 'a m := 'a m
955 module T2 : functor (Wrapped : Monad.S2) -> sig
956 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
957 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
958 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
959 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
960 val get : ('x,store) m
961 val gets : (store -> 'a) -> ('x,'a) m
962 val put : store -> ('x,unit) m
963 val puts : (store -> store) -> ('x,unit) m
965 module TP2 : functor (Wrapped : Monad.P2) -> sig
966 include module type of T2(Wrapped)
967 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
970 type store = Store.store
972 type 'a m = store -> 'a * store
973 type 'a result = store -> 'a * store
974 type 'a result_exn = store -> 'a
975 let unit a = fun s -> (a, s)
976 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
977 let run u = fun s -> (u s)
978 let run_exn u = fun s -> fst (u s)
980 include Monad.Make(Base)
981 let get = fun s -> (s, s)
982 let gets viewer = fun s -> (viewer s, s) (* may fail *)
983 let put s = fun _ -> ((), s)
984 let puts modifier = fun s -> ((), modifier s)
985 module T(Wrapped : Monad.S) = struct
986 module Trans = struct
987 module Wrapped = Wrapped
988 type 'a m = store -> ('a * store) Wrapped.m
989 type 'a result = store -> ('a * store) Wrapped.result
990 type 'a result_exn = store -> 'a Wrapped.result_exn
991 let elevate w = fun s ->
992 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
993 let bind u f = fun s ->
994 Wrapped.bind (u s) (fun (a, s') -> f a s')
995 let run u = fun s -> Wrapped.run (u s)
996 let run_exn u = fun s ->
997 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
1000 include Monad.MakeT(Trans)
1001 let get = fun s -> Wrapped.unit (s, s)
1002 let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
1003 let put s = fun _ -> Wrapped.unit ((), s)
1004 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
1006 module TP(Wrapped : Monad.P) = struct
1007 module TransP = struct
1009 let plus u v = fun s -> Wrapped.plus (u s) (v s)
1010 let zero () = elevate (Wrapped.zero ())
1012 let gets viewer = fun s ->
1013 try Wrapped.unit (viewer s, s)
1014 with Not_found -> Wrapped.zero ()
1016 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
1018 module T2(Wrapped : Monad.S2) = struct
1019 module Trans = struct
1020 module Wrapped = Wrapped
1021 type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
1022 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
1023 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
1024 (* code repetition, ugh *)
1025 let elevate w = fun s ->
1026 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
1027 let bind u f = fun s ->
1028 Wrapped.bind (u s) (fun (a, s') -> f a s')
1029 let run u = fun s -> Wrapped.run (u s)
1030 let run_exn u = fun s ->
1031 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
1032 in Wrapped.run_exn w
1034 include Monad.MakeT2(Trans)
1035 let get = fun s -> Wrapped.unit (s, s)
1036 let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
1037 let put s = fun _ -> Wrapped.unit ((), s)
1038 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
1040 module TP2(Wrapped : Monad.P2) = struct
1041 module TransP = struct
1043 (* code repetition, ugh *)
1044 let plus u v = fun s -> Wrapped.plus (u s) (v s)
1045 let zero () = elevate (Wrapped.zero ())
1047 let gets viewer = fun s ->
1048 try Wrapped.unit (viewer s, s)
1049 with Not_found -> Wrapped.zero ()
1051 include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
1055 (* State monad with different interface (structured store) *)
1056 module Ref_monad(V : sig
1060 type value = V.value
1062 type 'a result_exn = 'a
1063 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1064 val newref : value -> ref m
1065 val deref : ref -> value m
1066 val change : ref -> value -> unit m
1067 (* RefT transformer *)
1068 module T : functor (Wrapped : Monad.S) -> sig
1069 type 'a result = 'a Wrapped.result
1070 type 'a result_exn = 'a Wrapped.result_exn
1071 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1072 val elevate : 'a Wrapped.m -> 'a m
1073 val newref : value -> ref m
1074 val deref : ref -> value m
1075 val change : ref -> value -> unit m
1077 (* RefT transformer when wrapped monad has plus, zero *)
1078 module TP : functor (Wrapped : Monad.P) -> sig
1079 include module type of T(Wrapped)
1080 include Monad.PLUS with type 'a m := 'a m
1082 module T2 : functor (Wrapped : Monad.S2) -> sig
1083 type ('x,'a) result = ('x,'a) Wrapped.result
1084 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
1085 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1086 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
1087 val newref : value -> ('x,ref) m
1088 val deref : ref -> ('x,value) m
1089 val change : ref -> value -> ('x,unit) m
1091 module TP2 : functor (Wrapped : Monad.P2) -> sig
1092 include module type of T2(Wrapped)
1093 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
1097 type value = V.value
1098 module D = Map.Make(struct type t = ref let compare = compare end)
1099 type dict = { next: ref; tree : value D.t }
1100 let empty = { next = 0; tree = D.empty }
1101 let alloc (value : value) (d : dict) =
1102 (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
1103 let read (key : ref) (d : dict) =
1105 let write (key : ref) (value : value) (d : dict) =
1106 { next = d.next; tree = D.add key value d.tree }
1107 module Base = struct
1108 type 'a m = dict -> 'a * dict
1110 type 'a result_exn = 'a
1111 let unit a = fun s -> (a, s)
1112 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
1113 let run u = fst (u empty)
1116 include Monad.Make(Base)
1117 let newref value = fun s -> alloc value s
1118 let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
1119 let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
1120 module T(Wrapped : Monad.S) = struct
1121 module Trans = struct
1122 module Wrapped = Wrapped
1123 type 'a m = dict -> ('a * dict) Wrapped.m
1124 type 'a result = 'a Wrapped.result
1125 type 'a result_exn = 'a Wrapped.result_exn
1126 let elevate w = fun s ->
1127 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
1128 let bind u f = fun s ->
1129 Wrapped.bind (u s) (fun (a, s') -> f a s')
1131 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1134 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1135 in Wrapped.run_exn w
1137 include Monad.MakeT(Trans)
1138 let newref value = fun s -> Wrapped.unit (alloc value s)
1139 let deref key = fun s -> Wrapped.unit (read key s, s)
1140 let change key value = fun s -> Wrapped.unit ((), write key value s)
1142 module TP(Wrapped : Monad.P) = struct
1143 module TransP = struct
1145 let plus u v = fun s -> Wrapped.plus (u s) (v s)
1146 let zero () = elevate (Wrapped.zero ())
1149 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
1151 module T2(Wrapped : Monad.S2) = struct
1152 module Trans = struct
1153 module Wrapped = Wrapped
1154 type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
1155 type ('x,'a) result = ('x,'a) Wrapped.result
1156 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
1157 (* code repetition, ugh *)
1158 let elevate w = fun s ->
1159 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
1160 let bind u f = fun s ->
1161 Wrapped.bind (u s) (fun (a, s') -> f a s')
1163 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1166 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1167 in Wrapped.run_exn w
1169 include Monad.MakeT2(Trans)
1170 let newref value = fun s -> Wrapped.unit (alloc value s)
1171 let deref key = fun s -> Wrapped.unit (read key s, s)
1172 let change key value = fun s -> Wrapped.unit ((), write key value s)
1174 module TP2(Wrapped : Monad.P2) = struct
1175 module TransP = struct
1177 (* code repetition, ugh *)
1178 let plus u v = fun s -> Wrapped.plus (u s) (v s)
1179 let zero () = elevate (Wrapped.zero ())
1182 include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
1187 (* must be parameterized on (struct type log = ... end) *)
1188 module Writer_monad(Log : sig
1191 val plus : log -> log -> log
1193 (* declare additional operations, while still hiding implementation of type m *)
1195 type 'a result = 'a * log
1196 type 'a result_exn = 'a * log
1197 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1198 val tell : log -> unit m
1199 val listen : 'a m -> ('a * log) m
1200 val listens : (log -> 'b) -> 'a m -> ('a * 'b) m
1201 (* val pass : ('a * (log -> log)) m -> 'a m *)
1202 val censor : (log -> log) -> 'a m -> 'a m
1205 module Base = struct
1206 type 'a m = 'a * log
1207 type 'a result = 'a * log
1208 type 'a result_exn = 'a * log
1209 let unit a = (a, Log.zero)
1210 let bind (a, w) f = let (a', w') = f a in (a', Log.plus w w')
1214 include Monad.Make(Base)
1215 let tell entries = ((), entries) (* add entries to log *)
1216 let listen (a, w) = ((a, w), w)
1217 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
1218 let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
1219 let censor f u = pass (u >>= fun a -> unit (a, f))
1222 (* pre-define simple Writer *)
1223 module Writer1 = Writer_monad(struct
1226 let plus s1 s2 = s1 ^ "\n" ^ s2
1229 (* slightly more efficient Writer *)
1230 module Writer2 = struct
1231 include Writer_monad(struct
1232 type log = string list
1234 let plus w w' = Util.append w' w
1236 let tell_string s = tell [s]
1237 let tell entries = tell (Util.reverse entries)
1238 let run u = let (a, w) = run u in (a, Util.reverse w)
1243 module IO_monad : sig
1244 (* declare additional operation, while still hiding implementation of type m *)
1246 type 'a result_exn = 'a
1247 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1248 val printf : ('a, unit, string, unit m) format4 -> 'a
1249 val print_string : string -> unit m
1250 val print_int : int -> unit m
1251 val print_hex : int -> unit m
1252 val print_bool : bool -> unit m
1254 module Base = struct
1255 type 'a m = { run : unit -> unit; value : 'a }
1257 type 'a result_exn = 'a
1258 let unit a = { run = (fun () -> ()); value = a }
1259 let bind (a : 'a m) (f: 'a -> 'b m) : 'b m =
1260 let fres = f a.value in
1261 { run = (fun () -> a.run (); fres.run ()); value = fres.value }
1262 let run a = let () = a.run () in a.value
1265 include Monad.Make(Base)
1267 Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
1268 let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
1269 let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
1270 let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
1271 let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
1275 module Continuation_monad : sig
1276 (* expose only the implementation of type `('r,'a) result` *)
1278 type 'a result = 'a m
1279 type 'a result_exn = 'a m
1280 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn and type 'a m := 'a m
1281 (* val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m *)
1282 (* misses that the answer types of all the cont's must be the same *)
1283 val callcc : (('a -> 'b m) -> 'a m) -> 'a m
1284 (* val reset : ('a,'a) m -> ('r,'a) m *)
1285 val reset : 'a m -> 'a m
1286 (* val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m *)
1287 (* misses that the answer types of second and third continuations must be b *)
1288 val shift : (('a -> 'b m) -> 'b m) -> 'a m
1289 (* overwrite the run declaration in S, because I can't declare 'a result =
1290 * this polymorphic type (complains that 'r is unbound *)
1291 val runk : 'a m -> ('a -> 'r) -> 'r
1292 val run0 : 'a m -> 'a
1295 module Base = struct
1296 (* 'r is result type of whole computation *)
1297 type 'a m = { cont : 'r. ('a -> 'r) -> 'r }
1298 type 'a result = 'a m
1299 type 'a result_exn = 'a m
1301 let cont : 'r. ('a -> 'r) -> 'r =
1305 let cont : 'r. ('a -> 'r) -> 'r =
1306 fun k -> u.cont (fun a -> (f a).cont k)
1308 let run (u : 'a m) : 'a result = u
1309 let run_exn (u : 'a m) : 'a result_exn = u
1311 let cont : 'r. ('a -> 'r) -> 'r =
1312 (* Can't figure out how to make the type polymorphic enough
1313 * to satisfy the OCaml type-checker (it's ('a -> 'r) -> 'r
1314 * instead of 'r. ('a -> 'r) -> 'r); so we have to fudge
1315 * with Obj.magic... which tells OCaml's type checker to
1316 * relax, the supplied value has whatever type the context
1317 * needs it to have. *)
1319 let usek a = { cont = Obj.magic (fun _ -> k a) }
1322 let reset u = unit (u.cont id)
1323 let shift (f : ('a -> 'b m) -> 'b m) : 'a m =
1325 (f (fun a -> unit (k a))).cont id
1326 in { cont = Obj.magic cont }
1327 let runk u k = (u.cont : ('a -> 'r) -> 'r) k
1328 let run0 u = runk u id
1330 include Monad.Make(Base)
1331 let callcc = Base.callcc
1332 let reset = Base.reset
1333 let shift = Base.shift
1334 let runk = Base.runk
1335 let run0 = Base.run0
1339 (* This two-type parameter version works without Obj.magic *)
1340 module Continuation_monad : sig
1341 (* expose only the implementation of type `('r,'a) result` *)
1343 type ('r,'a) result = ('r,'a) m
1344 type ('r,'a) result_exn = ('a -> 'r) -> 'r
1345 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
1346 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
1347 val reset : ('a,'a) m -> ('r,'a) m
1348 val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
1349 (* val abort : ('a,'a) m -> ('a,'b) m *)
1350 val abort : 'a -> ('a,'b) m
1351 val run0 : ('a,'a) m -> 'a
1354 module Base = struct
1355 (* 'r is result type of whole computation *)
1356 type ('r,'a) m = ('a -> 'r) -> 'r
1357 type ('r,'a) result = ('a -> 'r) -> 'r
1358 type ('r,'a) result_exn = ('r,'a) result
1359 let unit a = (fun k -> k a)
1360 let bind u f = (fun k -> (u) (fun a -> (f a) k))
1364 include Monad.Make2(Base)
1365 let callcc f = (fun k ->
1366 let usek a = (fun _ -> k a)
1369 val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
1370 val throw : ('a -> 'r) -> 'a -> ('r,'b) m
1371 let callcc f = fun k -> f k k
1372 let throw k a = fun _ -> k a
1375 (* from http://www.haskell.org/haskellwiki/MonadCont_done_right
1377 * reset :: (Monad m) => ContT a m a -> ContT r m a
1378 * reset e = ContT $ \k -> runContT e return >>= k
1380 * shift :: (Monad m) => ((a -> ContT r m b) -> ContT b m b) -> ContT b m a
1381 * shift e = ContT $ \k ->
1382 * runContT (e $ \v -> ContT $ \c -> k v >>= c) return *)
1383 let reset u = unit ((u) id)
1384 let shift f = (fun k -> (f (fun a -> unit (k a))) id)
1385 (* let abort a = shift (fun _ -> a) *)
1386 let abort a = shift (fun _ -> unit a)
1387 let run0 (u : ('a,'a) m) = (u) id
1393 * (define (example n)
1394 * (let ([u (let/cc k ; type int -> int pair
1395 * (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
1396 * (+ 1 (car v))))]) ; int
1397 * (cons u 0))) ; int pair
1398 * ; (example 10) ~~> '(111 . 0)
1399 * ; (example -10) ~~> '(0 . 0)
1402 * let example n : (int * int) =
1403 * Continuation_monad.(let u = callcc (fun k ->
1404 * (if n < 0 then k 0 else unit [n + 100])
1405 * (* all of the following is skipped by k 0; the end type int is k's input type *)
1406 * >>= fun [x] -> unit (x + 1)
1408 * (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1409 * >>= fun x -> unit (x, 0)
1413 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1414 * let example1 () : int =
1415 * Continuation_monad.(let v = reset (
1416 * let u = shift (fun k -> unit (10 + 1))
1417 * in u >>= fun x -> unit (100 + x)
1418 * ) in let w = v >>= fun x -> unit (1000 + x)
1421 * (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1423 * Continuation_monad.(let v = reset (
1424 * let u = shift (fun k -> k (10 :: [1]))
1425 * in u >>= fun x -> unit (100 :: x)
1426 * ) in let w = v >>= fun x -> unit (1000 :: x)
1429 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1431 * Continuation_monad.(let v = reset (
1432 * let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1433 * in u >>= fun x -> unit (100 :: x)
1434 * ) in let w = v >>= fun x -> unit (1000 :: x)
1437 * (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1438 * (* not sure if this example can be typed without a sum-type *)
1440 * (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1441 * let example5 () : int =
1442 * Continuation_monad.(let v = reset (
1443 * let u = shift (fun k -> k 1 >>= fun x -> k x)
1444 * in u >>= fun x -> unit (10 + x)
1445 * ) in let w = v >>= fun x -> unit (100 + x)
1451 module Leaf_monad : sig
1452 (* We implement the type as `'a tree option` because it has a natural`plus`,
1453 * and the rest of the library expects that `plus` and `zero` will come together. *)
1454 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1455 type 'a result = 'a tree option
1456 type 'a result_exn = 'a tree
1457 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1458 include Monad.PLUS with type 'a m := 'a m
1459 (* LeafT transformer *)
1460 module T : functor (Wrapped : Monad.S) -> sig
1461 type 'a result = 'a tree option Wrapped.result
1462 type 'a result_exn = 'a tree Wrapped.result_exn
1463 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1464 include Monad.PLUS with type 'a m := 'a m
1465 val elevate : 'a Wrapped.m -> 'a m
1466 (* note that second argument is an 'a tree?, not the more abstract 'a m *)
1467 (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
1468 val distribute : ('a -> 'b Wrapped.m) -> 'a tree option -> 'b m
1470 module T2 : functor (Wrapped : Monad.S2) -> sig
1471 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1472 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1473 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1474 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
1475 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
1476 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
1479 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1480 (* uses supplied plus and zero to copy t to its image under f *)
1481 let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
1483 | Some ts -> let rec loop ts = (match ts with
1486 (* recursive application of f may delete a branch *)
1487 plus (loop l) (loop r)
1489 module Base = struct
1490 type 'a m = 'a tree option
1491 type 'a result = 'a tree option
1492 type 'a result_exn = 'a tree
1493 let unit a = Some (Leaf a)
1495 let plus u v = match (u, v) with
1498 | Some us, Some vs -> Some (Node (us, vs))
1499 let bind u f = mapT f u zero plus
1501 let run_exn u = match u with
1502 | None -> failwith "no values"
1504 | Some (Leaf a) -> a
1505 | many -> failwith "multiple values"
1509 include Monad.Make(Base)
1510 include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
1511 let base_plus = plus
1512 let base_lift = lift
1513 module T(Wrapped : Monad.S) = struct
1514 module Trans = struct
1515 let zero () = Wrapped.unit None
1517 Wrapped.bind u (fun us ->
1518 Wrapped.bind v (fun vs ->
1519 Wrapped.unit (base_plus us vs)))
1520 include Monad.MakeT(struct
1521 module Wrapped = Wrapped
1522 type 'a m = 'a tree option Wrapped.m
1523 type 'a result = 'a tree option Wrapped.result
1524 type 'a result_exn = 'a tree Wrapped.result_exn
1525 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1526 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1527 let run u = Wrapped.run u
1529 let w = Wrapped.bind u (fun t -> match t with
1530 | None -> failwith "no values"
1531 | Some ts -> Wrapped.unit ts)
1532 in Wrapped.run_exn w
1536 include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
1537 (* let distribute f t = mapT (fun a -> a) (base_lift (fun a -> elevate (f a)) t) zero plus *)
1538 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1540 module T2(Wrapped : Monad.S2) = struct
1541 module Trans = struct
1542 let zero () = Wrapped.unit None
1544 Wrapped.bind u (fun us ->
1545 Wrapped.bind v (fun vs ->
1546 Wrapped.unit (base_plus us vs)))
1547 include Monad.MakeT2(struct
1548 module Wrapped = Wrapped
1549 type ('x,'a) m = ('x,'a tree option) Wrapped.m
1550 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1551 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1552 (* code repetition, ugh *)
1553 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1554 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1555 let run u = Wrapped.run u
1557 let w = Wrapped.bind u (fun t -> match t with
1558 | None -> failwith "no values"
1559 | Some ts -> Wrapped.unit ts)
1560 in Wrapped.run_exn w
1564 include (Monad.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
1565 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1570 module L = List_monad;;
1571 module R = Reader_monad(struct type env = int -> int end);;
1572 module S = State_monad(struct type store = int end);;
1573 module T = Leaf_monad;;
1574 module LR = L.T(R);;
1575 module LS = L.T(S);;
1576 module TL = T.T(L);;
1577 module TR = T.T(R);;
1578 module TS = T.T(S);;
1579 module C = Continuation_monad
1580 module TC = T.T2(C);;
1583 print_endline "=== test Leaf(...).distribute ==================";;
1585 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))));;
1587 let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
1590 - : int T.tree option * S.store =
1593 (T.Node (T.Leaf 2, T.Leaf 3),
1594 T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
1598 let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
1601 - : (int * S.store) T.tree option * S.store =
1604 (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
1605 T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
1609 let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
1610 TR.run_exn tr (fun i -> i+i);;
1612 - : int T.tree option =
1615 (T.Node (T.Leaf 4, T.Leaf 6),
1616 T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
1619 let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
1622 - : (int * int) TL.result =
1625 (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
1626 T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
1629 let l2 = [1;2;3;4;5];;
1630 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))));;
1632 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);;
1633 (* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
1635 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);;
1640 (T.Node (T.Leaf 10, T.Leaf 11),
1643 (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
1644 T.Node (T.Leaf 40, T.Leaf 41)),
1645 T.Node (T.Leaf 50, T.Leaf 51))))
1648 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;;
1650 - : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
1653 print_endline "=== test Leaf(Continuation).distribute ==================";;
1655 let id : 'z. 'z -> 'z = fun x -> x
1657 let example n : (int * int) =
1658 Continuation_monad.(let u = callcc (fun k ->
1659 (if n < 0 then k 0 else unit [n + 100])
1660 (* all of the following is skipped by k 0; the end type int is k's input type *)
1661 >>= fun [x] -> unit (x + 1)
1663 (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1664 >>= fun x -> unit (x, 0)
1668 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1669 let example1 () : int =
1670 Continuation_monad.(let v = reset (
1671 let u = shift (fun k -> unit (10 + 1))
1672 in u >>= fun x -> unit (100 + x)
1673 ) in let w = v >>= fun x -> unit (1000 + x)
1676 (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1678 Continuation_monad.(let v = reset (
1679 let u = shift (fun k -> k (10 :: [1]))
1680 in u >>= fun x -> unit (100 :: x)
1681 ) in let w = v >>= fun x -> unit (1000 :: x)
1684 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1686 Continuation_monad.(let v = reset (
1687 let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1688 in u >>= fun x -> unit (100 :: x)
1689 ) in let w = v >>= fun x -> unit (1000 :: x)
1692 (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1693 (* not sure if this example can be typed without a sum-type *)
1695 (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1696 let example5 () : int =
1697 Continuation_monad.(let v = reset (
1698 let u = shift (fun k -> k 1 >>= k)
1699 in u >>= fun x -> unit (10 + x)
1700 ) in let w = v >>= fun x -> unit (100 + x)
1705 print_endline "=== test bare Continuation ============";;
1707 (1011, 1111, 1111, 121);;
1708 (example1(), example2(), example3(), example5());;
1710 (example ~+10, example ~-10);;
1713 C.run_exn TC.(run (distribute df t1)) ic;;
1718 let initial_continuation = fun t -> t in
1719 TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
1724 (* count leaves, using continuation *)
1725 let initial_continuation = fun t -> 0 in
1726 TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
1729 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
1732 (* convert tree to list of leaves *)
1733 let initial_continuation = fun t -> [] in
1734 TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
1737 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
1740 (* square each leaf using continuation *)
1741 let initial_continuation = fun t -> t in
1742 TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
1745 testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
1749 (* replace leaves with list, using continuation *)
1750 let initial_continuation = fun t -> t in
1751 TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
1754 testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;
1756 print_endline "=== pa_monad's Continuation Tests ============";;
1758 (1, 5 = C.(run0 (unit 1 >>= fun x -> unit (x+4))) );;
1759 (2, 9 = C.(run0 (reset (unit 5 >>= fun x -> unit (x+4)))) );;
1760 (3, 9 = C.(run0 (reset (abort 5 >>= fun y -> unit (y+6)) >>= fun x -> unit (x+4))) );;
1761 (4, 9 = C.(run0 (reset (reset (abort 5 >>= fun y -> unit (y+6))) >>= fun x -> unit (x+4))) );;
1763 let c = reset(abort 5 >>= fun y -> unit (y+6))
1764 in reset(c >>= fun v1 -> abort 7 >>= fun v2 -> unit (v2+10) ) >>= fun x -> unit (x+20))) );;
1766 (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))) );;
1768 (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))) );;
1770 (12, ["a"] = C.(run0 (reset (shift (fun f -> f [] >>= fun t -> unit ("a"::t) ) >>= fun xv -> shift (fun _ -> unit xv)))) );;
1773 (0, 15 = C.(run0 (let f k = k 10 >>= fun v-> unit (v+100) in reset (callcc f >>= fun v -> unit (v+5)))) );;