4 * Relies on features introduced in OCaml 3.12
6 * This library uses parameterized modules, see tree_monadize.ml for
7 * more examples and explanation.
9 * Some comparisons with the Haskell monadic libraries, which we mostly follow:
10 * In Haskell, the Reader 'a monadic type would be defined something like this:
11 * newtype Reader a = Reader { runReader :: env -> a }
12 * (For simplicity, I'm suppressing the fact that Reader is also parameterized
13 * on the type of env.)
14 * This creates a type wrapper around `env -> a`, so that Haskell will
15 * distinguish between values that have been specifically designated as
16 * being of type `Reader a`, and common-garden values of type `env -> a`.
17 * To lift an aribtrary expression E of type `env -> a` into an `Reader a`,
19 * Reader { runReader = E }
20 * or use any of the following equivalent shorthands:
23 * To drop an expression R of type `Reader a` back into an `env -> a`, you do
27 * The `newtype` in the type declaration ensures that Haskell does this all
28 * efficiently: though it regards E and R as type-distinct, their underlying
29 * machine implementation is identical and doesn't need to be transformed when
30 * lifting/dropping from one type to the other.
32 * Now, you _could_ also declare monads as record types in OCaml, too, _but_
33 * doing so would introduce an extra level of machine representation, and
34 * lifting/dropping from the one type to the other wouldn't be free like it is
37 * This library encapsulates the monadic types in another way: by
38 * making their implementations private. The interpreter won't let
39 * let you freely interchange the `'a Reader_monad.m`s defined below
40 * with `Reader_monad.env -> 'a`. The code in this library can see that
41 * those are equivalent, but code outside the library can't. Instead, you'll
42 * have to use operations like `run` to convert the abstract monadic types
43 * to types whose internals you have free access to.
48 (* Some library functions used below. *)
50 let fold_right = List.fold_right
52 let append = List.append
53 let reverse = List.rev
54 let concat = List.concat
55 let concat_map f lst = List.concat (List.map f lst)
56 (* let zip = List.combine *)
57 let unzip = List.split
58 let zip_with = List.map2
59 let replicate len fill =
61 if n == 0 then accu else loop (pred n) (fill :: accu)
68 * This module contains factories that extend a base set of
69 * monadic definitions with a larger family of standard derived values.
74 * Signature extenders:
76 * MakeCatch, MakeDistrib :: PLUSBASE -> PLUS
79 * MakeT :: TRANS (with Wrapped : S or P) -> custom sig
81 * Make2 :: BASE2 -> S2
82 * MakeCatch2, MakeDistrib2 :: PLUSBASE2 -> PLUS2 (P2 is merged sig)
83 * to wrap double-typed inner monads:
84 * MakeT2 :: TRANS2 (with Wrapped : S2 or P2) -> custom sig
90 (* type of base definitions *)
91 module type BASE = sig
92 (* The only constraints we impose here on how the monadic type
93 * is implemented is that it have a single type parameter 'a. *)
98 val bind : 'a m -> ('a -> 'b m) -> 'b m
99 val run : 'a m -> 'a result
100 (* run_exn tries to provide a more ground-level result, but may fail *)
101 val run_exn : 'a m -> 'a result_exn
105 val (>>=) : 'a m -> ('a -> 'b m) -> 'b m
106 val (>>) : 'a m -> 'b m -> 'b m
107 val join : ('a m) m -> 'a m
108 val apply : ('a -> 'b) m -> 'a m -> 'b m
109 val lift : ('a -> 'b) -> 'a m -> 'b m
110 val lift2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m
111 val (>=>) : ('a -> 'b m) -> ('b -> 'c m) -> 'a -> 'c m
112 val do_when : bool -> unit m -> unit m
113 val do_unless : bool -> unit m -> unit m
114 val forever : 'a m -> 'b m
115 val sequence : 'a m list -> 'a list m
116 val sequence_ : 'a m list -> unit m
119 (* Standard, single-type-parameter monads. *)
120 module Make(B : BASE) : S with type 'a m = 'a B.m and type 'a result = 'a B.result and type 'a result_exn = 'a B.result_exn = struct
123 let (>>) u v = u >>= fun _ -> v
124 let lift f u = u >>= fun a -> unit (f a)
125 (* lift is called listM, fmap, and <$> in Haskell *)
126 let join uu = uu >>= fun u -> u
127 (* u >>= f === join (lift f u) *)
128 let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
129 (* [f] <*> [x1,x2] = [f x1,f x2] *)
130 (* let apply u v = u >>= fun f -> lift f v *)
131 (* let apply = lift2 id *)
132 let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
133 (* let lift f u === apply (unit f) u *)
134 (* let lift2 f u v = apply (lift f u) v *)
135 let (>=>) f g = fun a -> f a >>= g
136 let do_when test u = if test then u else unit ()
137 let do_unless test u = if test then unit () else u
138 let rec forever u = u >> forever u
140 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
141 Util.fold_right op ms (unit [])
143 Util.fold_right (>>) ms (unit ())
145 (* Haskell defines these other operations combining lists and monads.
146 * We don't, but notice that M.mapM == ListT(M).distribute
147 * There's also a parallel TreeT(M).distribute *)
149 let mapM f alist = sequence (Util.map f alist)
150 let mapM_ f alist = sequence_ (Util.map f alist)
151 let rec filterM f lst = match lst with
153 | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
154 let forM alist f = mapM f alist
155 let forM_ alist f = mapM_ f alist
156 let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
157 let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
158 let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
159 let rec foldM f z lst = match lst with
161 | x::xs -> f z x >>= fun z' -> foldM f z' xs
162 let foldM_ f z xs = foldM f z xs >> unit ()
163 let replicateM n x = sequence (Util.replicate n x)
164 let replicateM_ n x = sequence_ (Util.replicate n x)
168 (* Single-type-parameter monads that also define `plus` and `zero`
169 * operations. These obey the following laws:
170 * zero >>= f === zero
173 * Additionally, these monads will obey one of the following laws:
174 * (Catch) plus (unit a) v === unit a
175 * (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
177 module type PLUSBASE = sig
179 val zero : unit -> 'a m
180 val plus : 'a m -> 'a m -> 'a m
182 module type PLUS = sig
184 val zero : unit -> 'a m
185 val plus : 'a m -> 'a m -> 'a m
186 val guard : bool -> unit m
187 val sum : 'a m list -> 'a m
189 (* MakeCatch and MakeDistrib have the same implementation; we just declare
190 * them twice to document which laws the client code is promising to honor. *)
191 module MakeCatch(B : PLUSBASE) : PLUS with type 'a m = 'a B.m = struct
195 let guard test = if test then B.unit () else zero ()
196 let sum ms = Util.fold_right plus ms (zero ())
198 module MakeDistrib = MakeCatch
200 (* Signatures for MonadT *)
201 (* sig for Wrapped that include S and PLUS *)
204 include PLUS with type 'a m := 'a m
206 module type TRANS = sig
211 val bind : 'a m -> ('a -> 'b m) -> 'b m
212 val run : 'a m -> 'a result
213 val run_exn : 'a m -> 'a result_exn
214 val elevate : 'a Wrapped.m -> 'a m
215 (* lift/elevate laws:
216 * elevate (W.unit a) == unit a
217 * elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
220 module MakeT(T : TRANS) = struct
223 let unit a = elevate (Wrapped.unit a)
225 let elevate = T.elevate
229 (* We have to define BASE, S, and Make again for double-type-parameter monads. *)
230 module type BASE2 = sig
233 type ('x,'a) result_exn
234 val unit : 'a -> ('x,'a) m
235 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
236 val run : ('x,'a) m -> ('x,'a) result
237 val run_exn : ('x,'a) m -> ('x,'a) result_exn
241 val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
242 val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
243 val join : ('x,('x,'a) m) m -> ('x,'a) m
244 val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
245 val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
246 val lift2 : ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
247 val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
248 val do_when : bool -> ('x,unit) m -> ('x,unit) m
249 val do_unless : bool -> ('x,unit) m -> ('x,unit) m
250 val forever : ('x,'a) m -> ('x,'b) m
251 val sequence : ('x,'a) m list -> ('x,'a list) m
252 val sequence_ : ('x,'a) m list -> ('x,unit) m
254 module Make2(B : BASE2) : S2 with type ('x,'a) m = ('x,'a) B.m and type ('x,'a) result = ('x,'a) B.result and type ('x,'a) result_exn = ('x,'a) B.result_exn = struct
255 (* code repetition, ugh *)
258 let (>>) u v = u >>= fun _ -> v
259 let lift f u = u >>= fun a -> unit (f a)
260 let join uu = uu >>= fun u -> u
261 let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
262 let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
263 let (>=>) f g = fun a -> f a >>= g
264 let do_when test u = if test then u else unit ()
265 let do_unless test u = if test then unit () else u
266 let rec forever u = u >> forever u
268 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
269 Util.fold_right op ms (unit [])
271 Util.fold_right (>>) ms (unit ())
274 module type PLUSBASE2 = sig
276 val zero : unit -> ('x,'a) m
277 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
279 module type PLUS2 = sig
281 val zero : unit -> ('x,'a) m
282 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
283 val guard : bool -> ('x,unit) m
284 val sum : ('x,'a) m list -> ('x,'a) m
286 module MakeCatch2(B : PLUSBASE2) : PLUS2 with type ('x,'a) m = ('x,'a) B.m = struct
287 type ('x,'a) m = ('x,'a) B.m
288 (* code repetition, ugh *)
291 let guard test = if test then B.unit () else zero ()
292 let sum ms = Util.fold_right plus ms (zero ())
294 module MakeDistrib2 = MakeCatch2
296 (* Signatures for MonadT *)
297 (* sig for Wrapped that include S and PLUS *)
300 include PLUS2 with type ('x,'a) m := ('x,'a) m
302 module type TRANS2 = sig
306 type ('x,'a) result_exn
307 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
308 val run : ('x,'a) m -> ('x,'a) result
309 val run_exn : ('x,'a) m -> ('x,'a) result_exn
310 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
312 module MakeT2(T : TRANS2) = struct
313 (* code repetition, ugh *)
316 let unit a = elevate (Wrapped.unit a)
318 let elevate = T.elevate
327 module Identity_monad : sig
328 (* expose only the implementation of type `'a result` *)
330 type 'a result_exn = 'a
331 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
336 type 'a result_exn = 'a
342 include Monad.Make(Base)
346 module Maybe_monad : sig
347 (* expose only the implementation of type `'a result` *)
348 type 'a result = 'a option
349 type 'a result_exn = 'a
350 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
351 include Monad.PLUS with type 'a m := 'a m
352 (* MaybeT transformer *)
353 module T : functor (Wrapped : Monad.S) -> sig
354 type 'a result = 'a option Wrapped.result
355 type 'a result_exn = 'a Wrapped.result_exn
356 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
357 include Monad.PLUS with type 'a m := 'a m
358 val elevate : 'a Wrapped.m -> 'a m
360 module T2 : functor (Wrapped : Monad.S2) -> sig
361 type ('x,'a) result = ('x,'a option) Wrapped.result
362 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
363 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
364 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
365 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
369 type 'a m = 'a option
370 type 'a result = 'a option
371 type 'a result_exn = 'a
373 let bind u f = match u with Some a -> f a | None -> None
375 let run_exn u = match u with
377 | None -> failwith "no value"
379 let plus u v = match u with None -> v | _ -> u
381 include Monad.Make(Base)
382 include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m)
383 module T(Wrapped : Monad.S) = struct
384 module Trans = struct
385 include Monad.MakeT(struct
386 module Wrapped = Wrapped
387 type 'a m = 'a option Wrapped.m
388 type 'a result = 'a option Wrapped.result
389 type 'a result_exn = 'a Wrapped.result_exn
390 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
391 let bind u f = Wrapped.bind u (fun t -> match t with
393 | None -> Wrapped.unit None)
394 let run u = Wrapped.run u
396 let w = Wrapped.bind u (fun t -> match t with
397 | Some a -> Wrapped.unit a
398 | None -> failwith "no value")
401 let zero () = Wrapped.unit None
402 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
405 include (Monad.MakeCatch(Trans) : Monad.PLUS with type 'a m := 'a m)
407 module T2(Wrapped : Monad.S2) = struct
408 module Trans = struct
409 include Monad.MakeT2(struct
410 module Wrapped = Wrapped
411 type ('x,'a) m = ('x,'a option) Wrapped.m
412 type ('x,'a) result = ('x,'a option) Wrapped.result
413 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
414 (* code repetition, ugh *)
415 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
416 let bind u f = Wrapped.bind u (fun t -> match t with
418 | None -> Wrapped.unit None)
419 let run u = Wrapped.run u
421 let w = Wrapped.bind u (fun t -> match t with
422 | Some a -> Wrapped.unit a
423 | None -> failwith "no value")
426 let zero () = Wrapped.unit None
427 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
430 include (Monad.MakeCatch2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
435 module List_monad : sig
436 (* declare additional operation, while still hiding implementation of type m *)
437 type 'a result = 'a list
438 type 'a result_exn = 'a
439 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
440 include Monad.PLUS with type 'a m := 'a m
441 val permute : 'a m -> 'a m m
442 val select : 'a m -> ('a * 'a m) m
443 (* ListT transformer *)
444 module T : functor (Wrapped : Monad.S) -> sig
445 type 'a result = 'a list Wrapped.result
446 type 'a result_exn = 'a Wrapped.result_exn
447 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
448 include Monad.PLUS with type 'a m := 'a m
449 val elevate : 'a Wrapped.m -> 'a m
450 (* note that second argument is an 'a list, not the more abstract 'a m *)
451 (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
452 val distribute : ('a -> 'b Wrapped.m) -> 'a list -> 'b m
454 val permute : 'a m -> 'a m m
455 val select : 'a m -> ('a * 'a m) m
458 module T2 : functor (Wrapped : Monad.S2) -> sig
459 type ('x,'a) result = ('x,'a list) Wrapped.result
460 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
461 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
462 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
463 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
464 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
469 type 'a result = 'a list
470 type 'a result_exn = 'a
472 let bind u f = Util.concat_map f u
474 let run_exn u = match u with
475 | [] -> failwith "no values"
477 | many -> failwith "multiple values"
479 let plus = Util.append
481 include Monad.Make(Base)
482 include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
483 (* let either u v = plus u v *)
484 (* insert 3 [1;2] ~~> [[3;1;2]; [1;3;2]; [1;2;3]] *)
486 plus (unit (a :: u)) (match u with
488 | x :: xs -> (insert a xs) >>= fun v -> unit (x :: v)
490 (* permute [1;2;3] ~~> [1;2;3]; [2;1;3]; [2;3;1]; [1;3;2]; [3;1;2]; [3;2;1] *)
491 let rec permute u = match u with
493 | x :: xs -> (permute xs) >>= (fun v -> insert x v)
494 (* select [1;2;3] ~~> [(1,[2;3]); (2,[1;3]), (3;[1;2])] *)
495 let rec select u = match u with
497 | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
499 module T(Wrapped : Monad.S) = struct
500 module Trans = struct
501 (* Wrapped.sequence ms ===
503 Wrapped.bind u (fun x ->
504 Wrapped.bind v (fun xs ->
505 Wrapped.unit (x :: xs)))
506 in Util.fold_right plus1 ms (Wrapped.unit []) *)
507 (* distribute === Wrapped.mapM; copies alist to its image under f *)
508 let distribute f alist = Wrapped.sequence (Util.map f alist)
509 include Monad.MakeT(struct
510 module Wrapped = Wrapped
511 type 'a m = 'a list Wrapped.m
512 type 'a result = 'a list Wrapped.result
513 type 'a result_exn = 'a Wrapped.result_exn
514 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
516 Wrapped.bind u (fun ts ->
517 Wrapped.bind (distribute f ts) (fun tts ->
518 Wrapped.unit (Util.concat tts)))
519 let run u = Wrapped.run u
521 let w = Wrapped.bind u (fun ts -> match ts with
522 | [] -> failwith "no values"
523 | [a] -> Wrapped.unit a
524 | many -> failwith "multiple values"
525 ) in Wrapped.run_exn w
527 let zero () = Wrapped.unit []
529 Wrapped.bind u (fun us ->
530 Wrapped.bind v (fun vs ->
531 Wrapped.unit (base_plus us vs)))
534 include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
536 let permute : 'a m -> 'a m m
537 let select : 'a m -> ('a * 'a m) m
540 module T2(Wrapped : Monad.S2) = struct
541 module Trans = struct
542 let distribute f alist = Wrapped.sequence (Util.map f alist)
543 include Monad.MakeT2(struct
544 module Wrapped = Wrapped
545 type ('x,'a) m = ('x,'a list) Wrapped.m
546 type ('x,'a) result = ('x,'a list) Wrapped.result
547 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
548 (* code repetition, ugh *)
549 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
551 Wrapped.bind u (fun ts ->
552 Wrapped.bind (distribute f ts) (fun tts ->
553 Wrapped.unit (Util.concat tts)))
554 let run u = Wrapped.run u
556 let w = Wrapped.bind u (fun ts -> match ts with
557 | [] -> failwith "no values"
558 | [a] -> Wrapped.unit a
559 | many -> failwith "multiple values"
560 ) in Wrapped.run_exn w
562 let zero () = Wrapped.unit []
564 Wrapped.bind u (fun us ->
565 Wrapped.bind v (fun vs ->
566 Wrapped.unit (base_plus us vs)))
569 include (Monad.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
574 (* must be parameterized on (struct type err = ... end) *)
575 module Error_monad(Err : sig
579 val zero : unit -> err
580 val plus : err -> err -> err
583 (* declare additional operations, while still hiding implementation of type m *)
585 type 'a error = Error of err | Success of 'a
587 type 'a result_exn = 'a
588 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
589 (* include Monad.PLUS with type 'a m := 'a m *)
590 val throw : err -> 'a m
591 val catch : 'a m -> (err -> 'a m) -> 'a m
592 (* ErrorT transformer *)
593 module T : functor (Wrapped : Monad.S) -> sig
594 type 'a result = 'a Wrapped.result
595 type 'a result_exn = 'a Wrapped.result_exn
596 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
597 val elevate : 'a Wrapped.m -> 'a m
598 val throw : err -> 'a m
599 val catch : 'a m -> (err -> 'a m) -> 'a m
601 module T2 : functor (Wrapped : Monad.S2) -> sig
602 type ('x,'a) result = ('x,'a) Wrapped.result
603 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
604 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
605 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
606 val throw : err -> ('x,'a) m
607 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
611 type 'a error = Error of err | Success of 'a
615 type 'a result_exn = 'a
616 let unit a = Success a
617 let bind u f = match u with
619 | Error e -> Error e (* input and output may be of different 'a types *)
620 (* TODO: should run refrain from failing? *)
621 let run u = match u with
623 | Error e -> raise (Err.Exc e)
626 let zero () = Error Err.zero
627 let plus u v = match (u, v) with
629 (* to satisfy (Catch) laws, plus u zero = u, even if u = Error _
630 * otherwise, plus (Error _) v = v *)
631 | Error _, _ when v = zero -> u
633 | Error e1, Error e2 when u <> zero -> Error (Err.plus e1 e2)
637 include Monad.Make(Base)
638 (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
639 let throw e = Error e
640 let catch u handler = match u with
642 | Error e -> handler e
643 module T(Wrapped : Monad.S) = struct
644 module Trans = struct
645 module Wrapped = Wrapped
646 type 'a m = 'a error Wrapped.m
647 type 'a result = 'a Wrapped.result
648 type 'a result_exn = 'a Wrapped.result_exn
649 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
650 let bind u f = Wrapped.bind u (fun t -> match t with
652 | Error e -> Wrapped.unit (Error e))
653 (* TODO: should run refrain from failing? *)
655 let w = Wrapped.bind u (fun t -> match t with
656 | Success a -> Wrapped.unit a
657 (* | _ -> Wrapped.fail () *)
658 | Error e -> raise (Err.Exc e))
661 let w = Wrapped.bind u (fun t -> match t with
662 | Success a -> Wrapped.unit a
663 (* | _ -> Wrapped.fail () *)
664 | Error e -> raise (Err.Exc e))
667 include Monad.MakeT(Trans)
668 let throw e = Wrapped.unit (Error e)
669 let catch u handler = Wrapped.bind u (fun t -> match t with
670 | Success _ -> Wrapped.unit t
671 | Error e -> handler e)
673 module T2(Wrapped : Monad.S2) = struct
674 module Trans = struct
675 module Wrapped = Wrapped
676 type ('x,'a) m = ('x,'a error) Wrapped.m
677 type ('x,'a) result = ('x,'a) Wrapped.result
678 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
679 (* code repetition, ugh *)
680 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
681 let bind u f = Wrapped.bind u (fun t -> match t with
683 | Error e -> Wrapped.unit (Error e))
685 let w = Wrapped.bind u (fun t -> match t with
686 | Success a -> Wrapped.unit a
687 | Error e -> raise (Err.Exc e))
690 let w = Wrapped.bind u (fun t -> match t with
691 | Success a -> Wrapped.unit a
692 | Error e -> raise (Err.Exc e))
695 include Monad.MakeT2(Trans)
696 let throw e = Wrapped.unit (Error e)
697 let catch u handler = Wrapped.bind u (fun t -> match t with
698 | Success _ -> Wrapped.unit t
699 | Error e -> handler e)
703 (* pre-define common instance of Error_monad *)
704 module Failure = Error_monad(struct
706 exception Exc = Failure
709 let plus s1 s2 = s1 ^ "\n" ^ s2
713 (* must be parameterized on (struct type env = ... end) *)
714 module Reader_monad(Env : sig type env end) : sig
715 (* declare additional operations, while still hiding implementation of type m *)
717 type 'a result = env -> 'a
718 type 'a result_exn = env -> 'a
719 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
721 val asks : (env -> 'a) -> 'a m
722 val local : (env -> env) -> 'a m -> 'a m
723 (* ReaderT transformer *)
724 module T : functor (Wrapped : Monad.S) -> sig
725 type 'a result = env -> 'a Wrapped.result
726 type 'a result_exn = env -> 'a Wrapped.result_exn
727 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
728 val elevate : 'a Wrapped.m -> 'a m
730 val asks : (env -> 'a) -> 'a m
731 val local : (env -> env) -> 'a m -> 'a m
733 (* ReaderT transformer when wrapped monad has plus, zero *)
734 module TP : functor (Wrapped : Monad.P) -> sig
735 include module type of T(Wrapped)
736 include Monad.PLUS with type 'a m := 'a m
738 module T2 : functor (Wrapped : Monad.S2) -> sig
739 type ('x,'a) result = env -> ('x,'a) Wrapped.result
740 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
741 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
742 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
744 val asks : (env -> 'a) -> ('x,'a) m
745 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
747 module TP2 : functor (Wrapped : Monad.P2) -> sig
748 include module type of T2(Wrapped)
749 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
754 type 'a m = env -> 'a
755 type 'a result = env -> 'a
756 type 'a result_exn = env -> 'a
757 let unit a = fun e -> a
758 let bind u f = fun e -> let a = u e in let u' = f a in u' e
759 let run u = fun e -> u e
762 include Monad.Make(Base)
764 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
765 let local modifier u = fun e -> u (modifier e)
766 module T(Wrapped : Monad.S) = struct
767 module Trans = struct
768 module Wrapped = Wrapped
769 type 'a m = env -> 'a Wrapped.m
770 type 'a result = env -> 'a Wrapped.result
771 type 'a result_exn = env -> 'a Wrapped.result_exn
772 let elevate w = fun e -> w
773 let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
774 let run u = fun e -> Wrapped.run (u e)
775 let run_exn u = fun e -> Wrapped.run_exn (u e)
777 include Monad.MakeT(Trans)
778 let ask = fun e -> Wrapped.unit e
779 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
780 let local modifier u = fun e -> u (modifier e)
782 module TP(Wrapped : Monad.P) = struct
783 module TransP = struct
785 let plus u v = fun s -> Wrapped.plus (u s) (v s)
786 let zero () = elevate (Wrapped.zero ())
787 let asks selector = ask >>= (fun e ->
788 try unit (selector e)
789 with Not_found -> fun e -> Wrapped.zero ())
792 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
794 module T2(Wrapped : Monad.S2) = struct
795 module Trans = struct
796 module Wrapped = Wrapped
797 type ('x,'a) m = env -> ('x,'a) Wrapped.m
798 type ('x,'a) result = env -> ('x,'a) Wrapped.result
799 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
800 (* code repetition, ugh *)
801 let elevate w = fun e -> w
802 let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
803 let run u = fun e -> Wrapped.run (u e)
804 let run_exn u = fun e -> Wrapped.run_exn (u e)
806 include Monad.MakeT2(Trans)
807 let ask = fun e -> Wrapped.unit e
808 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
809 let local modifier u = fun e -> u (modifier e)
811 module TP2(Wrapped : Monad.P2) = struct
812 module TransP = struct
813 (* code repetition, ugh *)
815 let plus u v = fun s -> Wrapped.plus (u s) (v s)
816 let zero () = elevate (Wrapped.zero ())
817 let asks selector = ask >>= (fun e ->
818 try unit (selector e)
819 with Not_found -> fun e -> Wrapped.zero ())
822 include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
827 (* must be parameterized on (struct type store = ... end) *)
828 module State_monad(Store : sig type store end) : sig
829 (* declare additional operations, while still hiding implementation of type m *)
830 type store = Store.store
831 type 'a result = store -> 'a * store
832 type 'a result_exn = store -> 'a
833 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
835 val gets : (store -> 'a) -> 'a m
836 val put : store -> unit m
837 val puts : (store -> store) -> unit m
838 (* StateT transformer *)
839 module T : functor (Wrapped : Monad.S) -> sig
840 type 'a result = store -> ('a * store) Wrapped.result
841 type 'a result_exn = store -> 'a Wrapped.result_exn
842 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
843 val elevate : 'a Wrapped.m -> 'a m
845 val gets : (store -> 'a) -> 'a m
846 val put : store -> unit m
847 val puts : (store -> store) -> unit m
849 (* StateT transformer when wrapped monad has plus, zero *)
850 module TP : functor (Wrapped : Monad.P) -> sig
851 include module type of T(Wrapped)
852 include Monad.PLUS with type 'a m := 'a m
854 module T2 : functor (Wrapped : Monad.S2) -> sig
855 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
856 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
857 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
858 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
859 val get : ('x,store) m
860 val gets : (store -> 'a) -> ('x,'a) m
861 val put : store -> ('x,unit) m
862 val puts : (store -> store) -> ('x,unit) m
864 module TP2 : functor (Wrapped : Monad.P2) -> sig
865 include module type of T2(Wrapped)
866 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
869 type store = Store.store
871 type 'a m = store -> 'a * store
872 type 'a result = store -> 'a * store
873 type 'a result_exn = store -> 'a
874 let unit a = fun s -> (a, s)
875 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
876 let run u = fun s -> (u s)
877 let run_exn u = fun s -> fst (u s)
879 include Monad.Make(Base)
880 let get = fun s -> (s, s)
881 let gets viewer = fun s -> (viewer s, s) (* may fail *)
882 let put s = fun _ -> ((), s)
883 let puts modifier = fun s -> ((), modifier s)
884 module T(Wrapped : Monad.S) = struct
885 module Trans = struct
886 module Wrapped = Wrapped
887 type 'a m = store -> ('a * store) Wrapped.m
888 type 'a result = store -> ('a * store) Wrapped.result
889 type 'a result_exn = store -> 'a Wrapped.result_exn
890 let elevate w = fun s ->
891 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
892 let bind u f = fun s ->
893 Wrapped.bind (u s) (fun (a, s') -> f a s')
894 let run u = fun s -> Wrapped.run (u s)
895 let run_exn u = fun s ->
896 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
899 include Monad.MakeT(Trans)
900 let get = fun s -> Wrapped.unit (s, s)
901 let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
902 let put s = fun _ -> Wrapped.unit ((), s)
903 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
905 module TP(Wrapped : Monad.P) = struct
906 module TransP = struct
908 let plus u v = fun s -> Wrapped.plus (u s) (v s)
909 let zero () = elevate (Wrapped.zero ())
911 let gets viewer = fun s ->
912 try Wrapped.unit (viewer s, s)
913 with Not_found -> Wrapped.zero ()
915 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
917 module T2(Wrapped : Monad.S2) = struct
918 module Trans = struct
919 module Wrapped = Wrapped
920 type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
921 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
922 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
923 (* code repetition, ugh *)
924 let elevate w = fun s ->
925 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
926 let bind u f = fun s ->
927 Wrapped.bind (u s) (fun (a, s') -> f a s')
928 let run u = fun s -> Wrapped.run (u s)
929 let run_exn u = fun s ->
930 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
933 include Monad.MakeT2(Trans)
934 let get = fun s -> Wrapped.unit (s, s)
935 let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
936 let put s = fun _ -> Wrapped.unit ((), s)
937 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
939 module TP2(Wrapped : Monad.P2) = struct
940 module TransP = struct
942 let plus u v = fun s -> Wrapped.plus (u s) (v s)
943 let zero () = elevate (Wrapped.zero ())
945 let gets viewer = fun s ->
946 try Wrapped.unit (viewer s, s)
947 with Not_found -> Wrapped.zero ()
949 include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
953 (* State monad with different interface (structured store) *)
954 module Ref_monad(V : sig
960 type 'a result_exn = 'a
961 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
962 val newref : value -> ref m
963 val deref : ref -> value m
964 val change : ref -> value -> unit m
965 (* RefT transformer *)
966 module T : functor (Wrapped : Monad.S) -> sig
967 type 'a result = 'a Wrapped.result
968 type 'a result_exn = 'a Wrapped.result_exn
969 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
970 val elevate : 'a Wrapped.m -> 'a m
971 val newref : value -> ref m
972 val deref : ref -> value m
973 val change : ref -> value -> unit m
975 (* RefT transformer when wrapped monad has plus, zero *)
976 module TP : functor (Wrapped : Monad.P) -> sig
977 include module type of T(Wrapped)
978 include Monad.PLUS with type 'a m := 'a m
980 module T2 : functor (Wrapped : Monad.S2) -> sig
981 type ('x,'a) result = ('x,'a) Wrapped.result
982 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
983 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
984 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
985 val newref : value -> ('x,ref) m
986 val deref : ref -> ('x,value) m
987 val change : ref -> value -> ('x,unit) m
989 module TP2 : functor (Wrapped : Monad.P2) -> sig
990 include module type of T2(Wrapped)
991 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
996 module D = Map.Make(struct type t = ref let compare = compare end)
997 type dict = { next: ref; tree : value D.t }
998 let empty = { next = 0; tree = D.empty }
999 let alloc (value : value) (d : dict) =
1000 (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
1001 let read (key : ref) (d : dict) =
1003 let write (key : ref) (value : value) (d : dict) =
1004 { next = d.next; tree = D.add key value d.tree }
1005 module Base = struct
1006 type 'a m = dict -> 'a * dict
1008 type 'a result_exn = 'a
1009 let unit a = fun s -> (a, s)
1010 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
1011 let run u = fst (u empty)
1014 include Monad.Make(Base)
1015 let newref value = fun s -> alloc value s
1016 let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
1017 let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
1018 module T(Wrapped : Monad.S) = struct
1019 module Trans = struct
1020 module Wrapped = Wrapped
1021 type 'a m = dict -> ('a * dict) Wrapped.m
1022 type 'a result = 'a Wrapped.result
1023 type 'a result_exn = 'a Wrapped.result_exn
1024 let elevate w = fun s ->
1025 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
1026 let bind u f = fun s ->
1027 Wrapped.bind (u s) (fun (a, s') -> f a s')
1029 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1032 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1033 in Wrapped.run_exn w
1035 include Monad.MakeT(Trans)
1036 let newref value = fun s -> Wrapped.unit (alloc value s)
1037 let deref key = fun s -> Wrapped.unit (read key s, s)
1038 let change key value = fun s -> Wrapped.unit ((), write key value s)
1040 module TP(Wrapped : Monad.P) = struct
1041 module TransP = struct
1043 let plus u v = fun s -> Wrapped.plus (u s) (v s)
1044 let zero () = elevate (Wrapped.zero ())
1047 include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
1049 module T2(Wrapped : Monad.S2) = struct
1050 module Trans = struct
1051 module Wrapped = Wrapped
1052 type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
1053 type ('x,'a) result = ('x,'a) Wrapped.result
1054 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
1055 (* code repetition, ugh *)
1056 let elevate w = fun s ->
1057 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
1058 let bind u f = fun s ->
1059 Wrapped.bind (u s) (fun (a, s') -> f a s')
1061 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1064 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1065 in Wrapped.run_exn w
1067 include Monad.MakeT2(Trans)
1068 let newref value = fun s -> Wrapped.unit (alloc value s)
1069 let deref key = fun s -> Wrapped.unit (read key s, s)
1070 let change key value = fun s -> Wrapped.unit ((), write key value s)
1072 module TP2(Wrapped : Monad.P2) = struct
1073 module TransP = struct
1075 let plus u v = fun s -> Wrapped.plus (u s) (v s)
1076 let zero () = elevate (Wrapped.zero ())
1079 include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
1084 (* must be parameterized on (struct type log = ... end) *)
1085 module Writer_monad(Log : sig
1088 val plus : log -> log -> log
1090 (* declare additional operations, while still hiding implementation of type m *)
1092 type 'a result = 'a * log
1093 type 'a result_exn = 'a * log
1094 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1095 val tell : log -> unit m
1096 val listen : 'a m -> ('a * log) m
1097 val listens : (log -> 'b) -> 'a m -> ('a * 'b) m
1098 (* val pass : ('a * (log -> log)) m -> 'a m *)
1099 val censor : (log -> log) -> 'a m -> 'a m
1102 module Base = struct
1103 type 'a m = 'a * log
1104 type 'a result = 'a * log
1105 type 'a result_exn = 'a * log
1106 let unit a = (a, Log.zero)
1107 let bind (a, w) f = let (a', w') = f a in (a', Log.plus w w')
1111 include Monad.Make(Base)
1112 let tell entries = ((), entries) (* add entries to log *)
1113 let listen (a, w) = ((a, w), w)
1114 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
1115 let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
1116 let censor f u = pass (u >>= fun a -> unit (a, f))
1119 (* pre-define simple Writer *)
1120 module Writer1 = Writer_monad(struct
1123 let plus s1 s2 = s1 ^ "\n" ^ s2
1126 (* slightly more efficient Writer *)
1127 module Writer2 = struct
1128 include Writer_monad(struct
1129 type log = string list
1131 let plus w w' = Util.append w' w
1133 let tell_string s = tell [s]
1134 let tell entries = tell (Util.reverse entries)
1135 let run u = let (a, w) = run u in (a, Util.reverse w)
1140 module IO_monad : sig
1141 (* declare additional operation, while still hiding implementation of type m *)
1143 type 'a result_exn = 'a
1144 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1145 val printf : ('a, unit, string, unit m) format4 -> 'a
1146 val print_string : string -> unit m
1147 val print_int : int -> unit m
1148 val print_hex : int -> unit m
1149 val print_bool : bool -> unit m
1151 module Base = struct
1152 type 'a m = { run : unit -> unit; value : 'a }
1154 type 'a result_exn = 'a
1155 let unit a = { run = (fun () -> ()); value = a }
1156 let bind (a : 'a m) (f: 'a -> 'b m) : 'b m =
1157 let fres = f a.value in
1158 { run = (fun () -> a.run (); fres.run ()); value = fres.value }
1159 let run a = let () = a.run () in a.value
1162 include Monad.Make(Base)
1164 Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
1165 let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
1166 let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
1167 let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
1168 let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
1172 module Continuation_monad : sig
1173 (* expose only the implementation of type `('r,'a) result` *)
1175 type 'a result = 'a m
1176 type 'a result_exn = 'a m
1177 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn and type 'a m := 'a m
1178 (* val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m *)
1179 (* misses that the answer types of all the cont's must be the same *)
1180 val callcc : (('a -> 'b m) -> 'a m) -> 'a m
1181 (* val reset : ('a,'a) m -> ('r,'a) m *)
1182 val reset : 'a m -> 'a m
1183 (* val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m *)
1184 (* misses that the answer types of second and third continuations must be b *)
1185 val shift : (('a -> 'b m) -> 'b m) -> 'a m
1186 (* overwrite the run declaration in S, because I can't declare 'a result =
1187 * this polymorphic type (complains that 'r is unbound *)
1188 val runk : 'a m -> ('a -> 'r) -> 'r
1189 val run0 : 'a m -> 'a
1192 module Base = struct
1193 (* 'r is result type of whole computation *)
1194 type 'a m = { cont : 'r. ('a -> 'r) -> 'r }
1195 type 'a result = 'a m
1196 type 'a result_exn = 'a m
1198 let cont : 'r. ('a -> 'r) -> 'r =
1202 let cont : 'r. ('a -> 'r) -> 'r =
1203 fun k -> u.cont (fun a -> (f a).cont k)
1205 let run (u : 'a m) : 'a result = u
1206 let run_exn (u : 'a m) : 'a result_exn = u
1208 let cont : 'r. ('a -> 'r) -> 'r =
1209 (* Can't figure out how to make the type polymorphic enough
1210 * to satisfy the OCaml type-checker (it's ('a -> 'r) -> 'r
1211 * instead of 'r. ('a -> 'r) -> 'r); so we have to fudge
1212 * with Obj.magic... which tells OCaml's type checker to
1213 * relax, the supplied value has whatever type the context
1214 * needs it to have. *)
1216 let usek a = { cont = Obj.magic (fun _ -> k a) }
1219 let reset u = unit (u.cont id)
1220 let shift (f : ('a -> 'b m) -> 'b m) : 'a m =
1222 (f (fun a -> unit (k a))).cont id
1223 in { cont = Obj.magic cont }
1224 let runk u k = (u.cont : ('a -> 'r) -> 'r) k
1225 let run0 u = runk u id
1227 include Monad.Make(Base)
1228 let callcc = Base.callcc
1229 let reset = Base.reset
1230 let shift = Base.shift
1231 let runk = Base.runk
1232 let run0 = Base.run0
1236 (* This two-type parameter version works without Obj.magic *)
1237 module Continuation_monad : sig
1238 (* expose only the implementation of type `('r,'a) result` *)
1240 type ('r,'a) result = ('r,'a) m
1241 type ('r,'a) result_exn = ('a -> 'r) -> 'r
1242 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
1243 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
1244 val reset : ('a,'a) m -> ('r,'a) m
1245 val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
1246 val abort : ('a,'a) m -> ('a,'b) m
1247 val run0 : ('a,'a) m -> 'a
1250 module Base = struct
1251 (* 'r is result type of whole computation *)
1252 type ('r,'a) m = ('a -> 'r) -> 'r
1253 type ('r,'a) result = ('a -> 'r) -> 'r
1254 type ('r,'a) result_exn = ('r,'a) result
1255 let unit a = (fun k -> k a)
1256 let bind u f = (fun k -> (u) (fun a -> (f a) k))
1260 include Monad.Make2(Base)
1261 let callcc f = (fun k ->
1262 let usek a = (fun _ -> k a)
1265 val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
1266 val throw : ('a -> 'r) -> 'a -> ('r,'b) m
1267 let callcc f = fun k -> f k k
1268 let throw k a = fun _ -> k a
1270 (* from http://www.haskell.org/haskellwiki/MonadCont_done_right *)
1271 let reset u = unit ((u) id)
1272 let shift f = (fun k -> (f (fun a -> unit (k a))) id)
1273 let abort a = shift (fun _ -> a)
1274 let run0 (u : ('a,'a) m) = (u) id
1280 * (define (example n)
1281 * (let ([u (let/cc k ; type int -> int pair
1282 * (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
1283 * (+ 1 (car v))))]) ; int
1284 * (cons u 0))) ; int pair
1285 * ; (example 10) ~~> '(111 . 0)
1286 * ; (example -10) ~~> '(0 . 0)
1289 * let example n : (int * int) =
1290 * Continuation_monad.(let u = callcc (fun k ->
1291 * (if n < 0 then k 0 else unit [n + 100])
1292 * (* all of the following is skipped by k 0; the end type int is k's input type *)
1293 * >>= fun [x] -> unit (x + 1)
1295 * (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1296 * >>= fun x -> unit (x, 0)
1300 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1301 * let example1 () : int =
1302 * Continuation_monad.(let v = reset (
1303 * let u = shift (fun k -> unit (10 + 1))
1304 * in u >>= fun x -> unit (100 + x)
1305 * ) in let w = v >>= fun x -> unit (1000 + x)
1308 * (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1310 * Continuation_monad.(let v = reset (
1311 * let u = shift (fun k -> k (10 :: [1]))
1312 * in u >>= fun x -> unit (100 :: x)
1313 * ) in let w = v >>= fun x -> unit (1000 :: x)
1316 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1318 * Continuation_monad.(let v = reset (
1319 * let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1320 * in u >>= fun x -> unit (100 :: x)
1321 * ) in let w = v >>= fun x -> unit (1000 :: x)
1324 * (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1325 * (* not sure if this example can be typed without a sum-type *)
1327 * (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1328 * let example5 () : int =
1329 * Continuation_monad.(let v = reset (
1330 * let u = shift (fun k -> k 1 >>= fun x -> k x)
1331 * in u >>= fun x -> unit (10 + x)
1332 * ) in let w = v >>= fun x -> unit (100 + x)
1338 module Leaf_monad : sig
1339 (* We implement the type as `'a tree option` because it has a natural`plus`,
1340 * and the rest of the library expects that `plus` and `zero` will come together. *)
1341 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1342 type 'a result = 'a tree option
1343 type 'a result_exn = 'a tree
1344 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1345 include Monad.PLUS with type 'a m := 'a m
1346 (* LeafT transformer *)
1347 module T : functor (Wrapped : Monad.S) -> sig
1348 type 'a result = 'a tree option Wrapped.result
1349 type 'a result_exn = 'a tree Wrapped.result_exn
1350 include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1351 include Monad.PLUS with type 'a m := 'a m
1352 val elevate : 'a Wrapped.m -> 'a m
1353 (* note that second argument is an 'a tree?, not the more abstract 'a m *)
1354 (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
1355 val distribute : ('a -> 'b Wrapped.m) -> 'a tree option -> 'b m
1357 module T2 : functor (Wrapped : Monad.S2) -> sig
1358 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1359 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1360 include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1361 include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
1362 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
1363 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
1366 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1367 (* uses supplied plus and zero to copy t to its image under f *)
1368 let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
1370 | Some ts -> let rec loop ts = (match ts with
1373 (* recursive application of f may delete a branch *)
1374 plus (loop l) (loop r)
1376 module Base = struct
1377 type 'a m = 'a tree option
1378 type 'a result = 'a tree option
1379 type 'a result_exn = 'a tree
1380 let unit a = Some (Leaf a)
1382 let plus u v = match (u, v) with
1385 | Some us, Some vs -> Some (Node (us, vs))
1386 let bind u f = mapT f u zero plus
1388 let run_exn u = match u with
1389 | None -> failwith "no values"
1391 | Some (Leaf a) -> a
1392 | many -> failwith "multiple values"
1396 include Monad.Make(Base)
1397 include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
1398 let base_plus = plus
1399 let base_lift = lift
1400 module T(Wrapped : Monad.S) = struct
1401 module Trans = struct
1402 let zero () = Wrapped.unit None
1404 Wrapped.bind u (fun us ->
1405 Wrapped.bind v (fun vs ->
1406 Wrapped.unit (base_plus us vs)))
1407 include Monad.MakeT(struct
1408 module Wrapped = Wrapped
1409 type 'a m = 'a tree option Wrapped.m
1410 type 'a result = 'a tree option Wrapped.result
1411 type 'a result_exn = 'a tree Wrapped.result_exn
1412 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1413 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1414 let run u = Wrapped.run u
1416 let w = Wrapped.bind u (fun t -> match t with
1417 | None -> failwith "no values"
1418 | Some ts -> Wrapped.unit ts)
1419 in Wrapped.run_exn w
1423 include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
1424 (* let distribute f t = mapT (fun a -> a) (base_lift (fun a -> elevate (f a)) t) zero plus *)
1425 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1427 module T2(Wrapped : Monad.S2) = struct
1428 module Trans = struct
1429 let zero () = Wrapped.unit None
1431 Wrapped.bind u (fun us ->
1432 Wrapped.bind v (fun vs ->
1433 Wrapped.unit (base_plus us vs)))
1434 include Monad.MakeT2(struct
1435 module Wrapped = Wrapped
1436 type ('x,'a) m = ('x,'a tree option) Wrapped.m
1437 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1438 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1439 (* code repetition, ugh *)
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.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
1452 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1457 module L = List_monad;;
1458 module R = Reader_monad(struct type env = int -> int end);;
1459 module S = State_monad(struct type store = int end);;
1460 module T = Leaf_monad;;
1461 module LR = L.T(R);;
1462 module LS = L.T(S);;
1463 module TL = T.T(L);;
1464 module TR = T.T(R);;
1465 module TS = T.T(S);;
1466 module C = Continuation_monad
1467 module TC = T.T2(C);;
1470 print_endline "================================================";;
1472 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))));;
1474 let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
1477 - : int T.tree option * S.store =
1480 (T.Node (T.Leaf 2, T.Leaf 3),
1481 T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
1485 let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
1488 - : (int * S.store) T.tree option * S.store =
1491 (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
1492 T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
1496 let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
1497 TR.run_exn tr (fun i -> i+i);;
1499 - : int T.tree option =
1502 (T.Node (T.Leaf 4, T.Leaf 6),
1503 T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
1506 let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
1509 - : (int * int) TL.result =
1512 (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
1513 T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
1516 let l2 = [1;2;3;4;5];;
1517 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))));;
1519 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);;
1520 (* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
1522 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);;
1527 (T.Node (T.Leaf 10, T.Leaf 11),
1530 (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
1531 T.Node (T.Leaf 40, T.Leaf 41)),
1532 T.Node (T.Leaf 50, T.Leaf 51))))
1535 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;;
1537 - : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
1541 let id : 'z. 'z -> 'z = fun x -> x
1543 let example n : (int * int) =
1544 Continuation_monad.(let u = callcc (fun k ->
1545 (if n < 0 then k 0 else unit [n + 100])
1546 (* all of the following is skipped by k 0; the end type int is k's input type *)
1547 >>= fun [x] -> unit (x + 1)
1549 (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1550 >>= fun x -> unit (x, 0)
1554 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1555 let example1 () : int =
1556 Continuation_monad.(let v = reset (
1557 let u = shift (fun k -> unit (10 + 1))
1558 in u >>= fun x -> unit (100 + x)
1559 ) in let w = v >>= fun x -> unit (1000 + x)
1562 (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1564 Continuation_monad.(let v = reset (
1565 let u = shift (fun k -> k (10 :: [1]))
1566 in u >>= fun x -> unit (100 :: x)
1567 ) in let w = v >>= fun x -> unit (1000 :: x)
1570 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1572 Continuation_monad.(let v = reset (
1573 let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1574 in u >>= fun x -> unit (100 :: x)
1575 ) in let w = v >>= fun x -> unit (1000 :: x)
1578 (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1579 (* not sure if this example can be typed without a sum-type *)
1581 (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1582 let example5 () : int =
1583 Continuation_monad.(let v = reset (
1584 let u = shift (fun k -> k 1 >>= fun x -> k x)
1585 in u >>= fun x -> unit (10 + x)
1586 ) in let w = v >>= fun x -> unit (100 + x)
1592 (1011, 1111, 1111, 121);;
1593 (example1(), example2(), example3(), example5());;
1595 (example ~+10, example ~-10);;
1598 C.run_exn TC.(run (distribute df t1)) ic;;
1603 let initial_continuation = fun t -> t in
1604 TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
1609 (* count leaves, using continuation *)
1610 let initial_continuation = fun t -> 0 in
1611 TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
1614 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
1617 (* convert tree to list of leaves *)
1618 let initial_continuation = fun t -> [] in
1619 TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
1622 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
1625 (* square each leaf using continuation *)
1626 let initial_continuation = fun t -> t in
1627 TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
1630 testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
1634 (* replace leaves with list, using continuation *)
1635 let initial_continuation = fun t -> t in
1636 TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
1639 testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;