4 * Relies on features introduced in OCaml 3.12
6 * This library uses parameterized modules, see tree_monadize.ml for
7 * more examples and explanation.
9 * Some comparisons with the Haskell monadic libraries, which we mostly follow:
10 * In Haskell, the Reader 'a monadic type would be defined something like this:
11 * newtype Reader a = Reader { runReader :: env -> a }
12 * (For simplicity, I'm suppressing the fact that Reader is also parameterized
13 * on the type of env.)
14 * This creates a type wrapper around `env -> a`, so that Haskell will
15 * distinguish between values that have been specifically designated as
16 * being of type `Reader a`, and common-garden values of type `env -> a`.
17 * To lift an aribtrary expression E of type `env -> a` into an `Reader a`,
19 * Reader { runReader = E }
20 * or use any of the following equivalent shorthands:
23 * To drop an expression R of type `Reader a` back into an `env -> a`, you do
27 * The `newtype` in the type declaration ensures that Haskell does this all
28 * efficiently: though it regards E and R as type-distinct, their underlying
29 * machine implementation is identical and doesn't need to be transformed when
30 * lifting/dropping from one type to the other.
32 * Now, you _could_ also declare monads as record types in OCaml, too, _but_
33 * doing so would introduce an extra level of machine representation, and
34 * lifting/dropping from the one type to the other wouldn't be free like it is
37 * This library encapsulates the monadic types in another way: by
38 * making their implementations private. The interpreter won't let
39 * let you freely interchange the `'a Reader_monad.m`s defined below
40 * with `Reader_monad.env -> 'a`. The code in this library can see that
41 * those are equivalent, but code outside the library can't. Instead, you'll
42 * have to use operations like `run` to convert the abstract monadic types
43 * to types whose internals you have free access to.
45 * Acknowledgements: This is largely based on the mtl library distributed
46 * with the Glasgow Haskell Compiler. I've also been helped in
47 * various ways by posts and direct feedback from Oleg Kiselyov and
48 * Chung-chieh Shan. The following were also useful:
49 * - <http://pauillac.inria.fr/~xleroy/mpri/progfunc/>
50 * - Ken Shan "Monads for natural language semantics" <http://arxiv.org/abs/cs/0205026v1>
51 * - http://www.grabmueller.de/martin/www/pub/Transformers.pdf
52 * - http://en.wikibooks.org/wiki/Haskell/Monad_transformers
54 * Licensing: MIT (if that's compatible with the ghc sources this is partly
60 (* Some library functions used below. *)
62 let fold_right = List.fold_right
64 let append = List.append
65 let reverse = List.rev
66 let concat = List.concat
67 let concat_map f lst = List.concat (List.map f lst)
68 (* let zip = List.combine *)
69 let unzip = List.split
70 let zip_with = List.map2
71 let replicate len fill =
73 if n == 0 then accu else loop (pred n) (fill :: accu)
75 (* Dirty hack to be a default polymorphic zero.
76 * To implement this cleanly, monads without a natural zero
77 * should always wrap themselves in an option layer (see Tree_monad). *)
78 let undef = Obj.magic (fun () -> raise Undefined)
84 * This module contains factories that extend a base set of
85 * monadic definitions with a larger family of standard derived values.
90 * Signature extenders:
92 * MakeT :: BASET (with Wrapped : S) -> result sig not declared
96 (* type of base definitions *)
97 module type BASE = sig
98 (* We make all monadic types doubly-parameterized so that they
99 * can layer nicely with Continuation, which needs the second
103 type ('x,'a) result_exn
104 val unit : 'a -> ('x,'a) m
105 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
106 val run : ('x,'a) m -> ('x,'a) result
107 (* run_exn tries to provide a more ground-level result, but may fail *)
108 val run_exn : ('x,'a) m -> ('x,'a) result_exn
109 (* To simplify the library, we require every monad to supply a plus and zero. These obey the following laws:
110 * zero >>= f === zero
113 * Additionally, they will obey one of the following laws:
114 * (Catch) plus (unit a) v === unit a
115 * (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
116 * When no natural zero is available, use `let zero () = Util.undef`.
117 * The Make functor automatically detects for zero >>= ..., and
118 * plus zero _, plus _ zero; it also substitutes zero for pattern-match failures.
120 val zero : unit -> ('x,'a) m
121 (* zero has to be thunked to ensure results are always poly enough *)
122 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
126 val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
127 val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
128 val join : ('x,('x,'a) m) m -> ('x,'a) m
129 val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
130 val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
131 val lift2 : ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
132 val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
133 val do_when : bool -> ('x,unit) m -> ('x,unit) m
134 val do_unless : bool -> ('x,unit) m -> ('x,unit) m
135 val forever : (unit -> ('x,'a) m) -> ('x,'b) m
136 val sequence : ('x,'a) m list -> ('x,'a list) m
137 val sequence_ : ('x,'a) m list -> ('x,unit) m
138 val guard : bool -> ('x,unit) m
139 val sum : ('x,'a) m list -> ('x,'a) m
142 module Make(B : BASE) : S with type ('x,'a) m = ('x,'a) B.m and type ('x,'a) result = ('x,'a) B.result and type ('x,'a) result_exn = ('x,'a) B.result_exn = struct
144 let bind (u : ('x,'a) m) (f : 'a -> ('x,'b) m) : ('x,'b) m =
145 if u == Util.undef then Util.undef
146 else B.bind u (fun a -> try f a with Match_failure _ -> zero ())
148 if u == Util.undef then v else if v == Util.undef then u else B.plus u v
150 if u == Util.undef then raise Undefined else B.run u
152 if u == Util.undef then raise Undefined else B.run_exn u
154 (* expressions after >> will be evaluated before they're passed to
155 * bind, so you can't do `zero () >> assert false`
156 * this works though: `zero () >>= fun _ -> assert false`
158 let (>>) u v = u >>= fun _ -> v
159 let lift f u = u >>= fun a -> unit (f a)
160 (* lift is called listM, fmap, and <$> in Haskell *)
161 let join uu = uu >>= fun u -> u
162 (* u >>= f === join (lift f u) *)
163 let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
164 (* [f] <*> [x1,x2] = [f x1,f x2] *)
165 (* let apply u v = u >>= fun f -> lift f v *)
166 (* let apply = lift2 id *)
167 let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
168 (* let lift f u === apply (unit f) u *)
169 (* let lift2 f u v = apply (lift f u) v *)
170 let (>=>) f g = fun a -> f a >>= g
171 let do_when test u = if test then u else unit ()
172 let do_unless test u = if test then unit () else u
173 (* A Haskell-like version works:
174 let rec forever uthunk = uthunk () >>= fun _ -> forever uthunk
175 * but the recursive call is not in tail position so this can stack overflow. *)
178 let id result = result in
179 let kcell = ref id in
181 let result = uthunk (kcell := id) >>= chained
184 kcell := loop; z (* we use z only for its polymorphism *)
186 (* Reimplementations of the preceding using a hand-rolled State or StateT
187 can also stack overflow. *)
189 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
190 Util.fold_right op ms (unit [])
192 Util.fold_right (>>) ms (unit ())
194 (* Haskell defines these other operations combining lists and monads.
195 * We don't, but notice that M.mapM == ListT(M).distribute
196 * There's also a parallel TreeT(M).distribute *)
198 let mapM f alist = sequence (Util.map f alist)
199 let mapM_ f alist = sequence_ (Util.map f alist)
200 let rec filterM f lst = match lst with
202 | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
203 let forM alist f = mapM f alist
204 let forM_ alist f = mapM_ f alist
205 let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
206 let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
207 let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
208 let rec foldM f z lst = match lst with
210 | x::xs -> f z x >>= fun z' -> foldM f z' xs
211 let foldM_ f z xs = foldM f z xs >> unit ()
212 let replicateM n x = sequence (Util.replicate n x)
213 let replicateM_ n x = sequence_ (Util.replicate n x)
215 let guard test = if test then B.unit () else zero ()
216 let sum ms = Util.fold_right plus ms (zero ())
219 (* Signatures for MonadT *)
220 module type BASET = sig
224 type ('x,'a) result_exn
225 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
226 val run : ('x,'a) m -> ('x,'a) result
227 val run_exn : ('x,'a) m -> ('x,'a) result_exn
228 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
229 (* lift/elevate laws:
230 * elevate (W.unit a) == unit a
231 * elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
233 val zero : unit -> ('x,'a) m
234 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
236 module MakeT(T : BASET) = struct
239 let unit a = elevate (Wrapped.unit a)
241 let elevate = T.elevate
250 module Identity_monad : sig
251 (* expose only the implementation of type `'a result` *)
252 type ('x,'a) result = 'a
253 type ('x,'a) result_exn = 'a
254 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
258 type ('x,'a) result = 'a
259 type ('x,'a) result_exn = 'a
264 let zero () = Util.undef
267 include Monad.Make(Base)
271 module Maybe_monad : sig
272 (* expose only the implementation of type `'a result` *)
273 type ('x,'a) result = 'a option
274 type ('x,'a) result_exn = 'a
275 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
276 (* MaybeT transformer *)
277 module T : functor (Wrapped : Monad.S) -> sig
278 type ('x,'a) result = ('x,'a option) Wrapped.result
279 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
280 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
281 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
285 type ('x,'a) m = 'a option
286 type ('x,'a) result = 'a option
287 type ('x,'a) result_exn = 'a
289 let bind u f = match u with Some a -> f a | None -> None
291 let run_exn u = match u with
293 | None -> failwith "no value"
295 (* satisfies Catch *)
296 let plus u v = match u with None -> v | _ -> u
298 include Monad.Make(Base)
299 module T(Wrapped : Monad.S) = struct
300 module BaseT = struct
301 include Monad.MakeT(struct
302 module Wrapped = Wrapped
303 type ('x,'a) m = ('x,'a option) Wrapped.m
304 type ('x,'a) result = ('x,'a option) Wrapped.result
305 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
306 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
307 let bind u f = Wrapped.bind u (fun t -> match t with
309 | None -> Wrapped.unit None)
310 let run u = Wrapped.run u
312 let w = Wrapped.bind u (fun t -> match t with
313 | Some a -> Wrapped.unit a
314 | None -> Wrapped.zero ()
315 ) in Wrapped.run_exn w
316 let zero () = Wrapped.unit None
317 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
325 module List_monad : sig
326 (* declare additional operation, while still hiding implementation of type m *)
327 type ('x,'a) result = 'a list
328 type ('x,'a) result_exn = 'a
329 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
330 val permute : ('x,'a) m -> ('x,('x,'a) m) m
331 val select : ('x,'a) m -> ('x,'a * ('x,'a) m) m
332 (* ListT transformer *)
333 module T : functor (Wrapped : Monad.S) -> sig
334 type ('x,'a) result = ('x,'a list) Wrapped.result
335 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
336 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
337 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
338 (* note that second argument is an 'a list, not the more abstract 'a m *)
339 (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
340 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
342 val permute : 'a m -> 'a m m
343 val select : 'a m -> ('a * 'a m) m
348 type ('x,'a) m = 'a list
349 type ('x,'a) result = 'a list
350 type ('x,'a) result_exn = 'a
352 let bind u f = Util.concat_map f u
354 let run_exn u = match u with
355 | [] -> failwith "no values"
357 | many -> failwith "multiple values"
359 (* satisfies Distrib *)
360 let plus = Util.append
362 include Monad.Make(Base)
363 (* let either u v = plus u v *)
364 (* insert 3 [1;2] ~~> [[3;1;2]; [1;3;2]; [1;2;3]] *)
366 plus (unit (a :: u)) (match u with
368 | x :: xs -> (insert a xs) >>= fun v -> unit (x :: v)
370 (* permute [1;2;3] ~~> [1;2;3]; [2;1;3]; [2;3;1]; [1;3;2]; [3;1;2]; [3;2;1] *)
371 let rec permute u = match u with
373 | x :: xs -> (permute xs) >>= (fun v -> insert x v)
374 (* select [1;2;3] ~~> [(1,[2;3]); (2,[1;3]), (3;[1;2])] *)
375 let rec select u = match u with
377 | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
378 module T(Wrapped : Monad.S) = struct
379 (* Wrapped.sequence ms ===
381 Wrapped.bind u (fun x ->
382 Wrapped.bind v (fun xs ->
383 Wrapped.unit (x :: xs)))
384 in Util.fold_right plus1 ms (Wrapped.unit []) *)
385 (* distribute === Wrapped.mapM; copies alist to its image under f *)
386 let distribute f alist = Wrapped.sequence (Util.map f alist)
388 include Monad.MakeT(struct
389 module Wrapped = Wrapped
390 type ('x,'a) m = ('x,'a list) Wrapped.m
391 type ('x,'a) result = ('x,'a list) Wrapped.result
392 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
393 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
395 Wrapped.bind u (fun ts ->
396 Wrapped.bind (distribute f ts) (fun tts ->
397 Wrapped.unit (Util.concat tts)))
398 let run u = Wrapped.run u
400 let w = Wrapped.bind u (fun ts -> match ts with
401 | [] -> Wrapped.zero ()
402 | [a] -> Wrapped.unit a
403 | many -> Wrapped.zero ()
404 ) in Wrapped.run_exn w
405 let zero () = Wrapped.unit []
407 Wrapped.bind u (fun us ->
408 Wrapped.bind v (fun vs ->
409 Wrapped.unit (Base.plus us vs)))
412 let permute : 'a m -> 'a m m
413 let select : 'a m -> ('a * 'a m) m
419 (* must be parameterized on (struct type err = ... end) *)
420 module Error_monad(Err : sig
424 val zero : unit -> err
425 val plus : err -> err -> err
428 (* declare additional operations, while still hiding implementation of type m *)
430 type 'a error = Error of err | Success of 'a
431 type ('x,'a) result = 'a error
432 type ('x,'a) result_exn = 'a
433 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
434 val throw : err -> ('x,'a) m
435 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
436 (* ErrorT transformer *)
437 module T : functor (Wrapped : Monad.S) -> sig
438 type ('x,'a) result = ('x,'a) Wrapped.result
439 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
440 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
441 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
442 val throw : err -> ('x,'a) m
443 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
447 type 'a error = Error of err | Success of 'a
449 type ('x,'a) m = 'a error
450 type ('x,'a) result = 'a error
451 type ('x,'a) result_exn = 'a
452 let unit a = Success a
453 let bind u f = match u with
455 | Error e -> Error e (* input and output may be of different 'a types *)
457 let run_exn u = match u with
459 | Error e -> raise (Err.Exc e)
460 let zero () = Util.undef
461 (* satisfies Catch *)
462 let plus u v = match u with
464 | Error _ -> if v == Util.undef then u else v
466 include Monad.Make(Base)
467 (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
468 let throw e = Error e
469 let catch u handler = match u with
471 | Error e -> handler e
472 module T(Wrapped : Monad.S) = struct
473 include Monad.MakeT(struct
474 module Wrapped = Wrapped
475 type ('x,'a) m = ('x,'a error) Wrapped.m
476 type ('x,'a) result = ('x,'a) Wrapped.result
477 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
478 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
479 let bind u f = Wrapped.bind u (fun t -> match t with
481 | Error e -> Wrapped.unit (Error e))
483 let w = Wrapped.bind u (fun t -> match t with
484 | Success a -> Wrapped.unit a
485 | Error e -> Wrapped.zero ()
488 let w = Wrapped.bind u (fun t -> match t with
489 | Success a -> Wrapped.unit a
490 | Error e -> raise (Err.Exc e))
492 let plus u v = Wrapped.plus u v
493 let zero () = Wrapped.zero () (* elevate (Wrapped.zero ()) *)
495 let throw e = Wrapped.unit (Error e)
496 let catch u handler = Wrapped.bind u (fun t -> match t with
497 | Success _ -> Wrapped.unit t
498 | Error e -> handler e)
502 (* pre-define common instance of Error_monad *)
503 module Failure = Error_monad(struct
505 exception Exc = Failure
508 let plus s1 s2 = s1 ^ "\n" ^ s2
513 (* must be parameterized on (struct type env = ... end) *)
514 module Reader_monad(Env : sig type env end) : sig
515 (* declare additional operations, while still hiding implementation of type m *)
517 type ('x,'a) result = env -> 'a
518 type ('x,'a) result_exn = env -> 'a
519 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
521 val asks : (env -> 'a) -> ('x,'a) m
522 (* lookup i == `fun e -> e i` would assume env is a functional type *)
523 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
524 (* ReaderT transformer *)
525 module T : functor (Wrapped : Monad.S) -> sig
526 type ('x,'a) result = env -> ('x,'a) Wrapped.result
527 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
528 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
529 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
531 val asks : (env -> 'a) -> ('x,'a) m
532 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
537 type ('x,'a) m = env -> 'a
538 type ('x,'a) result = env -> 'a
539 type ('x,'a) result_exn = env -> 'a
540 let unit a = fun e -> a
541 let bind u f = fun e -> let a = u e in let u' = f a in u' e
542 let run u = fun e -> u e
544 let zero () = Util.undef
547 include Monad.Make(Base)
549 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
550 let local modifier u = fun e -> u (modifier e)
551 module T(Wrapped : Monad.S) = struct
552 module BaseT = struct
553 module Wrapped = Wrapped
554 type ('x,'a) m = env -> ('x,'a) Wrapped.m
555 type ('x,'a) result = env -> ('x,'a) Wrapped.result
556 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
557 let elevate w = fun e -> w
558 let bind u f = fun e -> Wrapped.bind (u e) (fun a -> f a e)
559 let run u = fun e -> Wrapped.run (u e)
560 let run_exn u = fun e -> Wrapped.run_exn (u e)
561 (* satisfies Distrib *)
562 let plus u v = fun e -> Wrapped.plus (u e) (v e)
563 let zero () = fun e -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
565 include Monad.MakeT(BaseT)
566 let ask = Wrapped.unit
567 let local modifier u = fun e -> u (modifier e)
568 let asks selector = ask >>= (fun e ->
569 try unit (selector e)
570 with Not_found -> fun e -> Wrapped.zero ())
575 (* must be parameterized on (struct type store = ... end) *)
576 module State_monad(Store : sig type store end) : sig
577 (* declare additional operations, while still hiding implementation of type m *)
578 type store = Store.store
579 type ('x,'a) result = store -> 'a * store
580 type ('x,'a) result_exn = store -> 'a
581 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
582 val get : ('x,store) m
583 val gets : (store -> 'a) -> ('x,'a) m
584 val put : store -> ('x,unit) m
585 val puts : (store -> store) -> ('x,unit) m
586 (* StateT transformer *)
587 module T : functor (Wrapped : Monad.S) -> sig
588 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
589 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
590 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
591 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
592 val get : ('x,store) m
593 val gets : (store -> 'a) -> ('x,'a) m
594 val put : store -> ('x,unit) m
595 val puts : (store -> store) -> ('x,unit) m
598 type store = Store.store
600 type ('x,'a) m = store -> 'a * store
601 type ('x,'a) result = store -> 'a * store
602 type ('x,'a) result_exn = store -> 'a
603 let unit a = fun s -> (a, s)
604 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
605 let run u = fun s -> (u s)
606 let run_exn u = fun s -> fst (u s)
607 let zero () = Util.undef
610 include Monad.Make(Base)
611 let get = fun s -> (s, s)
612 let gets viewer = fun s -> (viewer s, s) (* may fail *)
613 let put s = fun _ -> ((), s)
614 let puts modifier = fun s -> ((), modifier s)
615 module T(Wrapped : Monad.S) = struct
616 module BaseT = struct
617 module Wrapped = Wrapped
618 type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
619 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
620 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
621 let elevate w = fun s ->
622 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
623 let bind u f = fun s ->
624 Wrapped.bind (u s) (fun (a, s') -> f a s')
625 let run u = fun s -> Wrapped.run (u s)
626 let run_exn u = fun s ->
627 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
629 (* satisfies Distrib *)
630 let plus u v = fun s -> Wrapped.plus (u s) (v s)
631 let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
633 include Monad.MakeT(BaseT)
634 let get = fun s -> Wrapped.unit (s, s)
635 let gets viewer = fun s ->
636 try Wrapped.unit (viewer s, s)
637 with Not_found -> Wrapped.zero ()
638 let put s = fun _ -> Wrapped.unit ((), s)
639 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
644 (* State monad with different interface (structured store) *)
645 module Ref_monad(V : sig
650 type ('x,'a) result = 'a
651 type ('x,'a) result_exn = 'a
652 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
653 val newref : value -> ('x,ref) m
654 val deref : ref -> ('x,value) m
655 val change : ref -> value -> ('x,unit) m
656 (* RefT transformer *)
657 module T : functor (Wrapped : Monad.S) -> sig
658 type ('x,'a) result = ('x,'a) Wrapped.result
659 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
660 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
661 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
662 val newref : value -> ('x,ref) m
663 val deref : ref -> ('x,value) m
664 val change : ref -> value -> ('x,unit) m
669 module D = Map.Make(struct type t = ref let compare = compare end)
670 type dict = { next: ref; tree : value D.t }
671 let empty = { next = 0; tree = D.empty }
672 let alloc (value : value) (d : dict) =
673 (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
674 let read (key : ref) (d : dict) =
676 let write (key : ref) (value : value) (d : dict) =
677 { next = d.next; tree = D.add key value d.tree }
679 type ('x,'a) m = dict -> 'a * dict
680 type ('x,'a) result = 'a
681 type ('x,'a) result_exn = 'a
682 let unit a = fun s -> (a, s)
683 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
684 let run u = fst (u empty)
686 let zero () = Util.undef
689 include Monad.Make(Base)
690 let newref value = fun s -> alloc value s
691 let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
692 let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
693 module T(Wrapped : Monad.S) = struct
694 module BaseT = struct
695 module Wrapped = Wrapped
696 type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
697 type ('x,'a) result = ('x,'a) Wrapped.result
698 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
699 let elevate w = fun s ->
700 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
701 let bind u f = fun s ->
702 Wrapped.bind (u s) (fun (a, s') -> f a s')
704 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
707 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
709 (* satisfies Distrib *)
710 let plus u v = fun s -> Wrapped.plus (u s) (v s)
711 let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
713 include Monad.MakeT(BaseT)
714 let newref value = fun s -> Wrapped.unit (alloc value s)
715 let deref key = fun s -> Wrapped.unit (read key s, s)
716 let change key value = fun s -> Wrapped.unit ((), write key value s)
721 (* must be parameterized on (struct type log = ... end) *)
722 module Writer_monad(Log : sig
725 val plus : log -> log -> log
727 (* declare additional operations, while still hiding implementation of type m *)
729 type ('x,'a) result = 'a * log
730 type ('x,'a) result_exn = 'a * log
731 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
732 val tell : log -> ('x,unit) m
733 val listen : ('x,'a) m -> ('x,'a * log) m
734 val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
735 (* val pass : ('x,'a * (log -> log)) m -> ('x,'a) m *)
736 val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
737 (* WriterT transformer *)
738 module T : functor (Wrapped : Monad.S) -> sig
739 type ('x,'a) result = ('x,'a * log) Wrapped.result
740 type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
741 include Monad.S 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
743 val tell : log -> ('x,unit) m
744 val listen : ('x,'a) m -> ('x,'a * log) m
745 val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
746 val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
751 type ('x,'a) m = 'a * log
752 type ('x,'a) result = 'a * log
753 type ('x,'a) result_exn = 'a * log
754 let unit a = (a, Log.zero)
755 let bind (a, w) f = let (b, w') = f a in (b, Log.plus w w')
758 let zero () = Util.undef
761 include Monad.Make(Base)
762 let tell entries = ((), entries) (* add entries to log *)
763 let listen (a, w) = ((a, w), w)
764 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
765 let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
766 let censor f u = pass (u >>= fun a -> unit (a, f))
767 module T(Wrapped : Monad.S) = struct
768 module BaseT = struct
769 module Wrapped = Wrapped
770 type ('x,'a) m = ('x,'a * log) Wrapped.m
771 type ('x,'a) result = ('x,'a * log) Wrapped.result
772 type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
774 Wrapped.bind w (fun a -> Wrapped.unit (a, Log.zero))
776 Wrapped.bind u (fun (a, w) ->
777 Wrapped.bind (f a) (fun (b, w') ->
778 Wrapped.unit (b, Log.plus w w')))
779 let zero () = elevate (Wrapped.zero ())
780 let plus u v = Wrapped.plus u v
781 let run u = Wrapped.run u
782 let run_exn u = Wrapped.run_exn u
784 include Monad.MakeT(BaseT)
785 let tell entries = Wrapped.unit ((), entries)
786 let listen u = Wrapped.bind u (fun (a, w) -> Wrapped.unit ((a, w), w))
787 let pass u = Wrapped.bind u (fun ((a, f), w) -> Wrapped.unit (a, f w))
788 (* rest are derived in same way as before *)
789 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w)
790 let censor f u = pass (u >>= fun a -> unit (a, f))
794 (* pre-define simple Writer *)
795 module Writer1 = Writer_monad(struct
798 let plus s1 s2 = s1 ^ "\n" ^ s2
801 (* slightly more efficient Writer *)
802 module Writer2 = struct
803 include Writer_monad(struct
804 type log = string list
806 let plus w w' = Util.append w' w
808 let tell_string s = tell [s]
809 let tell entries = tell (Util.reverse entries)
810 let run u = let (a, w) = run u in (a, Util.reverse w)
816 module IO_monad : sig
817 (* declare additional operation, while still hiding implementation of type m *)
818 type ('x,'a) result = 'a
819 type ('x,'a) result_exn = 'a
820 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
821 val printf : ('a, unit, string, ('x,unit) m) format4 -> 'a
822 val print_string : string -> ('x,unit) m
823 val print_int : int -> ('x,unit) m
824 val print_hex : int -> ('x,unit) m
825 val print_bool : bool -> ('x,unit) m
828 type ('x,'a) m = { run : unit -> unit; value : 'a }
829 type ('x,'a) result = 'a
830 type ('x,'a) result_exn = 'a
831 let unit a = { run = (fun () -> ()); value = a }
832 let bind (a : ('x,'a) m) (f: 'a -> ('x,'b) m) : ('x,'b) m =
833 let fres = f a.value in
834 { run = (fun () -> a.run (); fres.run ()); value = fres.value }
835 let run a = let () = a.run () in a.value
837 let zero () = Util.undef
840 include Monad.Make(Base)
842 Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
843 let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
844 let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
845 let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
846 let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
850 module Continuation_monad : sig
851 (* expose only the implementation of type `('r,'a) result` *)
853 type ('r,'a) result = ('r,'a) m
854 type ('r,'a) result_exn = ('a -> 'r) -> 'r
855 include Monad.S with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn and type ('r,'a) m := ('r,'a) m
856 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
857 val reset : ('a,'a) m -> ('r,'a) m
858 val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
859 (* val abort : ('a,'a) m -> ('a,'b) m *)
860 val abort : 'a -> ('a,'b) m
861 val run0 : ('a,'a) m -> 'a
862 (* ContinuationT transformer *)
863 module T : functor (Wrapped : Monad.S) -> sig
865 type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
866 type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
867 include Monad.S with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn and type ('r,'a) m := ('r,'a) m
868 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
869 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
870 (* TODO: reset,shift,abort,run0 *)
875 (* 'r is result type of whole computation *)
876 type ('r,'a) m = ('a -> 'r) -> 'r
877 type ('r,'a) result = ('a -> 'r) -> 'r
878 type ('r,'a) result_exn = ('r,'a) result
879 let unit a = (fun k -> k a)
880 let bind u f = (fun k -> (u) (fun a -> (f a) k))
883 let zero () = Util.undef
886 include Monad.Make(Base)
887 let callcc f = (fun k ->
888 let usek a = (fun _ -> k a)
891 val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
892 val throw : ('a -> 'r) -> 'a -> ('r,'b) m
893 let callcc f = fun k -> f k k
894 let throw k a = fun _ -> k a
897 (* from http://www.haskell.org/haskellwiki/MonadCont_done_right
899 * reset :: (Monad m) => ContT a m a -> ContT r m a
900 * reset e = ContT $ \k -> runContT e return >>= k
902 * shift :: (Monad m) => ((a -> ContT r m b) -> ContT b m b) -> ContT b m a
903 * shift e = ContT $ \k ->
904 * runContT (e $ \v -> ContT $ \c -> k v >>= c) return *)
905 let reset u = unit ((u) id)
906 let shift f = (fun k -> (f (fun a -> unit (k a))) id)
907 (* let abort a = shift (fun _ -> a) *)
908 let abort a = shift (fun _ -> unit a)
909 let run0 (u : ('a,'a) m) = (u) id
910 module T(Wrapped : Monad.S) = struct
911 module BaseT = struct
912 module Wrapped = Wrapped
913 type ('r,'a) m = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.m
914 type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
915 type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
916 let elevate w = fun k -> Wrapped.bind w k
917 let bind u f = fun k -> u (fun a -> f a k)
918 let run u k = Wrapped.run (u k)
919 let run_exn u k = Wrapped.run_exn (u k)
920 let zero () = Util.undef
923 include Monad.MakeT(BaseT)
924 let callcc f = (fun k ->
925 let usek a = (fun _ -> k a)
933 * (define (example n)
934 * (let ([u (let/cc k ; type int -> int pair
935 * (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
936 * (+ 1 (car v))))]) ; int
937 * (cons u 0))) ; int pair
938 * ; (example 10) ~~> '(111 . 0)
939 * ; (example -10) ~~> '(0 . 0)
942 * let example n : (int * int) =
943 * Continuation_monad.(let u = callcc (fun k ->
944 * (if n < 0 then k 0 else unit [n + 100])
945 * (* all of the following is skipped by k 0; the end type int is k's input type *)
946 * >>= fun [x] -> unit (x + 1)
948 * (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
949 * >>= fun x -> unit (x, 0)
955 module Tree_monad : sig
956 (* We implement the type as `'a tree option` because it has a natural`plus`,
957 * and the rest of the library expects that `plus` and `zero` will come together. *)
958 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
959 type ('x,'a) result = 'a tree option
960 type ('x,'a) result_exn = 'a tree
961 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
962 (* TreeT transformer *)
963 module T : functor (Wrapped : Monad.S) -> sig
964 type ('x,'a) result = ('x,'a tree option) Wrapped.result
965 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
966 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
967 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
968 (* note that second argument is an 'a tree?, not the more abstract 'a m *)
969 (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
970 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
973 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
974 (* uses supplied plus and zero to copy t to its image under f *)
975 let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
977 | Some ts -> let rec loop ts = (match ts with
980 (* recursive application of f may delete a branch *)
981 plus (loop l) (loop r)
984 type ('x,'a) m = 'a tree option
985 type ('x,'a) result = 'a tree option
986 type ('x,'a) result_exn = 'a tree
987 let unit a = Some (Leaf a)
989 (* satisfies Distrib *)
990 let plus u v = match (u, v) with
993 | Some us, Some vs -> Some (Node (us, vs))
994 let bind u f = mapT f u zero plus
996 let run_exn u = match u with
997 | None -> failwith "no values"
1000 | many -> failwith "multiple values"
1004 include Monad.Make(Base)
1005 module T(Wrapped : Monad.S) = struct
1006 module BaseT = struct
1007 include Monad.MakeT(struct
1008 module Wrapped = Wrapped
1009 type ('x,'a) m = ('x,'a tree option) Wrapped.m
1010 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1011 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1012 let zero () = Wrapped.unit None
1014 Wrapped.bind u (fun us ->
1015 Wrapped.bind v (fun vs ->
1016 Wrapped.unit (Base.plus us vs)))
1017 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1018 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1019 let run u = Wrapped.run u
1021 let w = Wrapped.bind u (fun t -> match t with
1022 | None -> Wrapped.zero ()
1023 | Some ts -> Wrapped.unit ts
1024 ) in Wrapped.run_exn w
1028 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus