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
59 (* Some library functions used below. *)
64 let fold_right = List.fold_right
66 let append = List.append
67 let reverse = List.rev
68 let concat = List.concat
69 let concat_map f lst = List.concat (List.map f lst)
70 (* let zip = List.combine *)
71 let unzip = List.split
72 let zip_with = List.map2
73 let replicate len fill =
75 if n == 0 then accu else loop (pred n) (fill :: accu)
77 (* Dirty hack to be a default polymorphic zero.
78 * To implement this cleanly, monads without a natural zero
79 * should always wrap themselves in an option layer (see Tree_monad). *)
80 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.
91 * Signature extenders:
93 * MakeT :: BASET (with Wrapped : S) -> result sig not declared
97 (* type of base definitions *)
98 module type BASE = sig
99 (* We make all monadic types doubly-parameterized so that they
100 * can layer nicely with Continuation, which needs the second
104 type ('x,'a) result_exn
105 val unit : 'a -> ('x,'a) m
106 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
107 val run : ('x,'a) m -> ('x,'a) result
108 (* run_exn tries to provide a more ground-level result, but may fail *)
109 val run_exn : ('x,'a) m -> ('x,'a) result_exn
110 (* To simplify the library, we require every monad to supply a plus and zero. These obey the following laws:
111 * zero >>= f === zero
114 * Additionally, they will obey one of the following laws:
115 * (Catch) plus (unit a) v === unit a
116 * (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
117 * When no natural zero is available, use `let zero () = Util.undef`.
118 * The Make functor automatically detects for zero >>= ..., and
119 * plus zero _, plus _ zero; it also substitutes zero for pattern-match failures.
121 val zero : unit -> ('x,'a) m
122 (* zero has to be thunked to ensure results are always poly enough *)
123 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
127 val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
128 val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
129 val join : ('x,('x,'a) m) m -> ('x,'a) m
130 val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
131 val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
132 val lift2 : ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
133 val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
134 val do_when : bool -> ('x,unit) m -> ('x,unit) m
135 val do_unless : bool -> ('x,unit) m -> ('x,unit) m
136 val forever : (unit -> ('x,'a) m) -> ('x,'b) m
137 val sequence : ('x,'a) m list -> ('x,'a list) m
138 val sequence_ : ('x,'a) m list -> ('x,unit) m
139 val guard : bool -> ('x,unit) m
140 val sum : ('x,'a) m list -> ('x,'a) m
143 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
145 let bind (u : ('x,'a) m) (f : 'a -> ('x,'b) m) : ('x,'b) m =
146 if u == Util.undef then Util.undef
147 else B.bind u (fun a -> try f a with Match_failure _ -> zero ())
149 if u == Util.undef then v else if v == Util.undef then u else B.plus u v
151 if u == Util.undef then raise Undefined else B.run u
153 if u == Util.undef then raise Undefined else B.run_exn u
155 (* expressions after >> will be evaluated before they're passed to
156 * bind, so you can't do `zero () >> assert false`
157 * this works though: `zero () >>= fun _ -> assert false`
159 let (>>) u v = u >>= fun _ -> v
160 let lift f u = u >>= fun a -> unit (f a)
161 (* lift is called listM, fmap, and <$> in Haskell *)
162 let join uu = uu >>= fun u -> u
163 (* u >>= f === join (lift f u) *)
164 let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
165 (* [f] <*> [x1,x2] = [f x1,f x2] *)
166 (* let apply u v = u >>= fun f -> lift f v *)
167 (* let apply = lift2 id *)
168 let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
169 (* let lift f u === apply (unit f) u *)
170 (* let lift2 f u v = apply (lift f u) v *)
171 let (>=>) f g = fun a -> f a >>= g
172 let do_when test u = if test then u else unit ()
173 let do_unless test u = if test then unit () else u
174 (* A Haskell-like version works:
175 let rec forever uthunk = uthunk () >>= fun _ -> forever uthunk
176 * but the recursive call is not in tail position so this can stack overflow. *)
179 let id result = result in
180 let kcell = ref id in
182 let result = uthunk (kcell := id) >>= chained
185 kcell := loop; z (* we use z only for its polymorphism *)
187 (* Reimplementations of the preceding using a hand-rolled State or StateT
188 can also stack overflow. *)
190 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
191 Util.fold_right op ms (unit [])
193 Util.fold_right (>>) ms (unit ())
195 (* Haskell defines these other operations combining lists and monads.
196 * We don't, but notice that M.mapM == ListT(M).distribute
197 * There's also a parallel TreeT(M).distribute *)
199 let mapM f alist = sequence (Util.map f alist)
200 let mapM_ f alist = sequence_ (Util.map f alist)
201 let rec filterM f lst = match lst with
203 | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
204 let forM alist f = mapM f alist
205 let forM_ alist f = mapM_ f alist
206 let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
207 let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
208 let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
209 let rec foldM f z lst = match lst with
211 | x::xs -> f z x >>= fun z' -> foldM f z' xs
212 let foldM_ f z xs = foldM f z xs >> unit ()
213 let replicateM n x = sequence (Util.replicate n x)
214 let replicateM_ n x = sequence_ (Util.replicate n x)
216 let guard test = if test then B.unit () else zero ()
217 let sum ms = Util.fold_right plus ms (zero ())
220 (* Signatures for MonadT *)
221 module type BASET = sig
225 type ('x,'a) result_exn
226 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
227 val run : ('x,'a) m -> ('x,'a) result
228 val run_exn : ('x,'a) m -> ('x,'a) result_exn
229 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
230 (* lift/elevate laws:
231 * elevate (W.unit a) == unit a
232 * elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
234 val zero : unit -> ('x,'a) m
235 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
237 module MakeT(T : BASET) = struct
240 let unit a = elevate (Wrapped.unit a)
242 let elevate = T.elevate
251 module Identity_monad : sig
252 (* expose only the implementation of type `'a result` *)
253 type ('x,'a) result = 'a
254 type ('x,'a) result_exn = 'a
255 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
259 type ('x,'a) result = 'a
260 type ('x,'a) result_exn = 'a
265 let zero () = Util.undef
268 include Monad.Make(Base)
272 module Maybe_monad : sig
273 (* expose only the implementation of type `'a result` *)
274 type ('x,'a) result = 'a option
275 type ('x,'a) result_exn = 'a
276 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
277 (* MaybeT transformer *)
278 module T : functor (Wrapped : Monad.S) -> sig
279 type ('x,'a) result = ('x,'a option) Wrapped.result
280 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
281 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
282 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
286 type ('x,'a) m = 'a option
287 type ('x,'a) result = 'a option
288 type ('x,'a) result_exn = 'a
290 let bind u f = match u with Some a -> f a | None -> None
292 let run_exn u = match u with
294 | None -> failwith "no value"
296 (* satisfies Catch *)
297 let plus u v = match u with None -> v | _ -> u
299 include Monad.Make(Base)
300 module T(Wrapped : Monad.S) = struct
301 module BaseT = struct
302 include Monad.MakeT(struct
303 module Wrapped = Wrapped
304 type ('x,'a) m = ('x,'a option) Wrapped.m
305 type ('x,'a) result = ('x,'a option) Wrapped.result
306 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
307 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
308 let bind u f = Wrapped.bind u (fun t -> match t with
310 | None -> Wrapped.unit None)
311 let run u = Wrapped.run u
313 let w = Wrapped.bind u (fun t -> match t with
314 | Some a -> Wrapped.unit a
315 | None -> Wrapped.zero ()
316 ) in Wrapped.run_exn w
317 let zero () = Wrapped.unit None
318 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
326 module List_monad : sig
327 (* declare additional operation, while still hiding implementation of type m *)
328 type ('x,'a) result = 'a list
329 type ('x,'a) result_exn = 'a
330 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
331 val permute : ('x,'a) m -> ('x,('x,'a) m) m
332 val select : ('x,'a) m -> ('x,'a * ('x,'a) m) m
333 (* ListT transformer *)
334 module T : functor (Wrapped : Monad.S) -> sig
335 type ('x,'a) result = ('x,'a list) Wrapped.result
336 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
337 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
338 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
339 (* note that second argument is an 'a list, not the more abstract 'a m *)
340 (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
341 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
342 val permute : ('x,'a) m -> ('x,('x,'a) m) m
343 val select : ('x,'a) m -> ('x,('a * ('x,'a) m)) m
344 val expose : ('x,'a) m -> ('x,'a list) Wrapped.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 (* insert 3 {[1;2]} ~~> {[ {[3;1;2]}; {[1;3;2]}; {[1;2;3]} ]} *)
415 (unit (Wrapped.bind u (fun us -> Wrapped.unit (a :: us))))
416 (Wrapped.bind u (fun us -> match us with
418 | x::xs -> (insert a (Wrapped.unit xs)) >>= fun v -> unit (Wrapped.bind v (fun vs -> Wrapped.unit (x :: vs)))))
420 (* select {[1;2;3]} ~~> {[ (1,{[2;3]}); (2,{[1;3]}), (3;{[1;2]}) ]} *)
422 Wrapped.bind u (fun us -> match us with
424 | x::xs -> plus (unit (x, Wrapped.unit xs))
425 (select (Wrapped.unit xs) >>= fun (x', xs') -> unit (x', Wrapped.bind xs' (fun ys -> Wrapped.unit (x :: ys)))))
427 (* permute {[1;2;3]} ~~> {[ {[1;2;3]}; {[2;1;3]}; {[2;3;1]}; {[1;3;2]}; {[3;1;2]}; {[3;2;1]} ]} *)
430 Wrapped.bind u (fun us -> match us with
431 | [] -> unit (zero ())
432 | x::xs -> permute (Wrapped.unit xs) >>= (fun v -> insert x v))
439 (* must be parameterized on (struct type err = ... end) *)
440 module Error_monad(Err : sig
444 val zero : unit -> err
445 val plus : err -> err -> err
448 (* declare additional operations, while still hiding implementation of type m *)
450 type 'a error = Error of err | Success of 'a
451 type ('x,'a) result = 'a error
452 type ('x,'a) result_exn = 'a
453 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
454 val throw : err -> ('x,'a) m
455 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
456 (* ErrorT transformer *)
457 module T : functor (Wrapped : Monad.S) -> sig
458 type ('x,'a) result = ('x,'a) Wrapped.result
459 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
460 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
461 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
462 val throw : err -> ('x,'a) m
463 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
467 type 'a error = Error of err | Success of 'a
469 type ('x,'a) m = 'a error
470 type ('x,'a) result = 'a error
471 type ('x,'a) result_exn = 'a
472 let unit a = Success a
473 let bind u f = match u with
475 | Error e -> Error e (* input and output may be of different 'a types *)
477 let run_exn u = match u with
479 | Error e -> raise (Err.Exc e)
480 let zero () = Util.undef
481 (* satisfies Catch *)
482 let plus u v = match u with
484 | Error _ -> if v == Util.undef then u else v
486 include Monad.Make(Base)
487 (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
488 let throw e = Error e
489 let catch u handler = match u with
491 | Error e -> handler e
492 module T(Wrapped : Monad.S) = struct
493 include Monad.MakeT(struct
494 module Wrapped = Wrapped
495 type ('x,'a) m = ('x,'a error) Wrapped.m
496 type ('x,'a) result = ('x,'a) Wrapped.result
497 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
498 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
499 let bind u f = Wrapped.bind u (fun t -> match t with
501 | Error e -> Wrapped.unit (Error e))
503 let w = Wrapped.bind u (fun t -> match t with
504 | Success a -> Wrapped.unit a
505 | Error e -> Wrapped.zero ()
508 let w = Wrapped.bind u (fun t -> match t with
509 | Success a -> Wrapped.unit a
510 | Error e -> raise (Err.Exc e))
512 let plus u v = Wrapped.plus u v
513 let zero () = Wrapped.zero () (* elevate (Wrapped.zero ()) *)
515 let throw e = Wrapped.unit (Error e)
516 let catch u handler = Wrapped.bind u (fun t -> match t with
517 | Success _ -> Wrapped.unit t
518 | Error e -> handler e)
522 (* pre-define common instance of Error_monad *)
523 module Failure = Error_monad(struct
525 exception Exc = Failure
528 let plus s1 s2 = s1 ^ "\n" ^ s2
533 (* must be parameterized on (struct type env = ... end) *)
534 module Reader_monad(Env : sig type env end) : sig
535 (* declare additional operations, while still hiding implementation of type m *)
537 type ('x,'a) result = env -> 'a
538 type ('x,'a) result_exn = env -> 'a
539 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
541 val asks : (env -> 'a) -> ('x,'a) m
542 (* lookup i == `fun e -> e i` would assume env is a functional type *)
543 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
544 (* ReaderT transformer *)
545 module T : functor (Wrapped : Monad.S) -> sig
546 type ('x,'a) result = env -> ('x,'a) Wrapped.result
547 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
548 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
549 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
551 val asks : (env -> 'a) -> ('x,'a) m
552 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
553 val expose : ('x,'a) m -> env -> ('x,'a) Wrapped.m
558 type ('x,'a) m = env -> 'a
559 type ('x,'a) result = env -> 'a
560 type ('x,'a) result_exn = env -> 'a
561 let unit a = fun e -> a
562 let bind u f = fun e -> let a = u e in let u' = f a in u' e
563 let run u = fun e -> u e
565 let zero () = Util.undef
568 include Monad.Make(Base)
570 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
571 let local modifier u = fun e -> u (modifier e)
572 module T(Wrapped : Monad.S) = struct
573 module BaseT = struct
574 module Wrapped = Wrapped
575 type ('x,'a) m = env -> ('x,'a) Wrapped.m
576 type ('x,'a) result = env -> ('x,'a) Wrapped.result
577 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
578 let elevate w = fun e -> w
579 let bind u f = fun e -> Wrapped.bind (u e) (fun a -> f a e)
580 let run u = fun e -> Wrapped.run (u e)
581 let run_exn u = fun e -> Wrapped.run_exn (u e)
582 (* satisfies Distrib *)
583 let plus u v = fun e -> Wrapped.plus (u e) (v e)
584 let zero () = fun e -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
586 include Monad.MakeT(BaseT)
587 let ask = Wrapped.unit
588 let local modifier u = fun e -> u (modifier e)
589 let asks selector = ask >>= (fun e ->
590 try unit (selector e)
591 with Not_found -> fun e -> Wrapped.zero ())
597 (* must be parameterized on (struct type store = ... end) *)
598 module State_monad(Store : sig type store end) : sig
599 (* declare additional operations, while still hiding implementation of type m *)
600 type store = Store.store
601 type ('x,'a) result = store -> 'a * store
602 type ('x,'a) result_exn = store -> 'a
603 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
604 val get : ('x,store) m
605 val gets : (store -> 'a) -> ('x,'a) m
606 val put : store -> ('x,unit) m
607 val puts : (store -> store) -> ('x,unit) m
608 (* StateT transformer *)
609 module T : functor (Wrapped : Monad.S) -> sig
610 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
611 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
612 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
613 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
614 val get : ('x,store) m
615 val gets : (store -> 'a) -> ('x,'a) m
616 val put : store -> ('x,unit) m
617 val puts : (store -> store) -> ('x,unit) m
618 (* val passthru : ('x,'a) m -> (('x,'a * store) Wrapped.result * store -> 'b) -> ('x,'b) m *)
619 val expose : ('x,'a) m -> store -> ('x,'a * store) Wrapped.m
622 type store = Store.store
624 type ('x,'a) m = store -> 'a * store
625 type ('x,'a) result = store -> 'a * store
626 type ('x,'a) result_exn = store -> 'a
627 let unit a = fun s -> (a, s)
628 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
629 let run u = fun s -> (u s)
630 let run_exn u = fun s -> fst (u s)
631 let zero () = Util.undef
634 include Monad.Make(Base)
635 let get = fun s -> (s, s)
636 let gets viewer = fun s -> (viewer s, s) (* may fail *)
637 let put s = fun _ -> ((), s)
638 let puts modifier = fun s -> ((), modifier s)
639 module T(Wrapped : Monad.S) = struct
640 module BaseT = struct
641 module Wrapped = Wrapped
642 type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
643 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
644 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
645 let elevate w = fun s ->
646 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
647 let bind u f = fun s ->
648 Wrapped.bind (u s) (fun (a, s') -> f a s')
649 let run u = fun s -> Wrapped.run (u s)
650 let run_exn u = fun s ->
651 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
653 (* satisfies Distrib *)
654 let plus u v = fun s -> Wrapped.plus (u s) (v s)
655 let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
657 include Monad.MakeT(BaseT)
658 let get = fun s -> Wrapped.unit (s, s)
659 let gets viewer = fun s ->
660 try Wrapped.unit (viewer s, s)
661 with Not_found -> Wrapped.zero ()
662 let put s = fun _ -> Wrapped.unit ((), s)
663 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
664 (* let passthru u f = fun s -> Wrapped.unit (f (Wrapped.run (u s), s), s) *)
670 (* State monad with different interface (structured store) *)
671 module Ref_monad(V : sig
676 type ('x,'a) result = 'a
677 type ('x,'a) result_exn = 'a
678 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
679 val newref : value -> ('x,ref) m
680 val deref : ref -> ('x,value) m
681 val change : ref -> value -> ('x,unit) m
682 (* RefT transformer *)
683 module T : functor (Wrapped : Monad.S) -> sig
684 type ('x,'a) result = ('x,'a) Wrapped.result
685 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
686 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
687 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
688 val newref : value -> ('x,ref) m
689 val deref : ref -> ('x,value) m
690 val change : ref -> value -> ('x,unit) m
695 module D = Map.Make(struct type t = ref let compare = compare end)
696 type dict = { next: ref; tree : value D.t }
697 let empty = { next = 0; tree = D.empty }
698 let alloc (value : value) (d : dict) =
699 (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
700 let read (key : ref) (d : dict) =
702 let write (key : ref) (value : value) (d : dict) =
703 { next = d.next; tree = D.add key value d.tree }
705 type ('x,'a) m = dict -> 'a * dict
706 type ('x,'a) result = 'a
707 type ('x,'a) result_exn = 'a
708 let unit a = fun s -> (a, s)
709 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
710 let run u = fst (u empty)
712 let zero () = Util.undef
715 include Monad.Make(Base)
716 let newref value = fun s -> alloc value s
717 let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
718 let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
719 module T(Wrapped : Monad.S) = struct
720 module BaseT = struct
721 module Wrapped = Wrapped
722 type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
723 type ('x,'a) result = ('x,'a) Wrapped.result
724 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
725 let elevate w = fun s ->
726 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
727 let bind u f = fun s ->
728 Wrapped.bind (u s) (fun (a, s') -> f a s')
730 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
733 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
735 (* satisfies Distrib *)
736 let plus u v = fun s -> Wrapped.plus (u s) (v s)
737 let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
739 include Monad.MakeT(BaseT)
740 let newref value = fun s -> Wrapped.unit (alloc value s)
741 let deref key = fun s -> Wrapped.unit (read key s, s)
742 let change key value = fun s -> Wrapped.unit ((), write key value s)
747 (* must be parameterized on (struct type log = ... end) *)
748 module Writer_monad(Log : sig
751 val plus : log -> log -> log
753 (* declare additional operations, while still hiding implementation of type m *)
755 type ('x,'a) result = 'a * log
756 type ('x,'a) result_exn = 'a * log
757 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
758 val tell : log -> ('x,unit) m
759 val listen : ('x,'a) m -> ('x,'a * log) m
760 val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
761 (* val pass : ('x,'a * (log -> log)) m -> ('x,'a) m *)
762 val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
763 (* WriterT transformer *)
764 module T : functor (Wrapped : Monad.S) -> sig
765 type ('x,'a) result = ('x,'a * log) Wrapped.result
766 type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
767 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
768 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
769 val tell : log -> ('x,unit) m
770 val listen : ('x,'a) m -> ('x,'a * log) m
771 val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
772 val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
777 type ('x,'a) m = 'a * log
778 type ('x,'a) result = 'a * log
779 type ('x,'a) result_exn = 'a * log
780 let unit a = (a, Log.zero)
781 let bind (a, w) f = let (b, w') = f a in (b, Log.plus w w')
784 let zero () = Util.undef
787 include Monad.Make(Base)
788 let tell entries = ((), entries) (* add entries to log *)
789 let listen (a, w) = ((a, w), w)
790 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
791 let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
792 let censor f u = pass (u >>= fun a -> unit (a, f))
793 module T(Wrapped : Monad.S) = struct
794 module BaseT = struct
795 module Wrapped = Wrapped
796 type ('x,'a) m = ('x,'a * log) Wrapped.m
797 type ('x,'a) result = ('x,'a * log) Wrapped.result
798 type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
800 Wrapped.bind w (fun a -> Wrapped.unit (a, Log.zero))
802 Wrapped.bind u (fun (a, w) ->
803 Wrapped.bind (f a) (fun (b, w') ->
804 Wrapped.unit (b, Log.plus w w')))
805 let zero () = elevate (Wrapped.zero ())
806 let plus u v = Wrapped.plus u v
807 let run u = Wrapped.run u
808 let run_exn u = Wrapped.run_exn u
810 include Monad.MakeT(BaseT)
811 let tell entries = Wrapped.unit ((), entries)
812 let listen u = Wrapped.bind u (fun (a, w) -> Wrapped.unit ((a, w), w))
813 let pass u = Wrapped.bind u (fun ((a, f), w) -> Wrapped.unit (a, f w))
814 (* rest are derived in same way as before *)
815 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w)
816 let censor f u = pass (u >>= fun a -> unit (a, f))
820 (* pre-define simple Writer *)
821 module Writer1 = Writer_monad(struct
824 let plus s1 s2 = s1 ^ "\n" ^ s2
827 (* slightly more efficient Writer *)
828 module Writer2 = struct
829 include Writer_monad(struct
830 type log = string list
832 let plus w w' = Util.append w' w
834 let tell_string s = tell [s]
835 let tell entries = tell (Util.reverse entries)
836 let run u = let (a, w) = run u in (a, Util.reverse w)
842 module IO_monad : sig
843 (* declare additional operation, while still hiding implementation of type m *)
844 type ('x,'a) result = 'a
845 type ('x,'a) result_exn = 'a
846 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
847 val printf : ('a, unit, string, ('x,unit) m) format4 -> 'a
848 val print_string : string -> ('x,unit) m
849 val print_int : int -> ('x,unit) m
850 val print_hex : int -> ('x,unit) m
851 val print_bool : bool -> ('x,unit) m
854 type ('x,'a) m = { run : unit -> unit; value : 'a }
855 type ('x,'a) result = 'a
856 type ('x,'a) result_exn = 'a
857 let unit a = { run = (fun () -> ()); value = a }
858 let bind (a : ('x,'a) m) (f: 'a -> ('x,'b) m) : ('x,'b) m =
859 let fres = f a.value in
860 { run = (fun () -> a.run (); fres.run ()); value = fres.value }
861 let run a = let () = a.run () in a.value
863 let zero () = Util.undef
866 include Monad.Make(Base)
868 Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
869 let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
870 let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
871 let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
872 let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
876 module Continuation_monad : sig
877 (* expose only the implementation of type `('r,'a) result` *)
879 type ('r,'a) result = ('r,'a) m
880 type ('r,'a) result_exn = ('a -> 'r) -> 'r
881 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
882 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
883 val reset : ('a,'a) m -> ('r,'a) m
884 val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
885 (* val abort : ('a,'a) m -> ('a,'b) m *)
886 val abort : 'a -> ('a,'b) m
887 val run0 : ('a,'a) m -> 'a
888 (* ContinuationT transformer *)
889 module T : functor (Wrapped : Monad.S) -> sig
891 type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
892 type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
893 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
894 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
895 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
896 (* TODO: reset,shift,abort,run0 *)
901 (* 'r is result type of whole computation *)
902 type ('r,'a) m = ('a -> 'r) -> 'r
903 type ('r,'a) result = ('a -> 'r) -> 'r
904 type ('r,'a) result_exn = ('r,'a) result
905 let unit a = (fun k -> k a)
906 let bind u f = (fun k -> (u) (fun a -> (f a) k))
909 let zero () = Util.undef
912 include Monad.Make(Base)
913 let callcc f = (fun k ->
914 let usek a = (fun _ -> k a)
917 val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
918 val throw : ('a -> 'r) -> 'a -> ('r,'b) m
919 let callcc f = fun k -> f k k
920 let throw k a = fun _ -> k a
923 (* from http://www.haskell.org/haskellwiki/MonadCont_done_right
925 * reset :: (Monad m) => ContT a m a -> ContT r m a
926 * reset e = ContT $ \k -> runContT e return >>= k
928 * shift :: (Monad m) => ((a -> ContT r m b) -> ContT b m b) -> ContT b m a
929 * shift e = ContT $ \k ->
930 * runContT (e $ \v -> ContT $ \c -> k v >>= c) return *)
931 let reset u = unit ((u) id)
932 let shift f = (fun k -> (f (fun a -> unit (k a))) id)
933 (* let abort a = shift (fun _ -> a) *)
934 let abort a = shift (fun _ -> unit a)
935 let run0 (u : ('a,'a) m) = (u) id
936 module T(Wrapped : Monad.S) = struct
937 module BaseT = struct
938 module Wrapped = Wrapped
939 type ('r,'a) m = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.m
940 type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
941 type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
942 let elevate w = fun k -> Wrapped.bind w k
943 let bind u f = fun k -> u (fun a -> f a k)
944 let run u k = Wrapped.run (u k)
945 let run_exn u k = Wrapped.run_exn (u k)
946 let zero () = Util.undef
949 include Monad.MakeT(BaseT)
950 let callcc f = (fun k ->
951 let usek a = (fun _ -> k a)
959 * (define (example n)
960 * (let ([u (let/cc k ; type int -> int pair
961 * (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
962 * (+ 1 (car v))))]) ; int
963 * (cons u 0))) ; int pair
964 * ; (example 10) ~~> '(111 . 0)
965 * ; (example -10) ~~> '(0 . 0)
968 * let example n : (int * int) =
969 * Continuation_monad.(let u = callcc (fun k ->
970 * (if n < 0 then k 0 else unit [n + 100])
971 * (* all of the following is skipped by k 0; the end type int is k's input type *)
972 * >>= fun [x] -> unit (x + 1)
974 * (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
975 * >>= fun x -> unit (x, 0)
981 module Tree_monad : sig
982 (* We implement the type as `'a tree option` because it has a natural`plus`,
983 * and the rest of the library expects that `plus` and `zero` will come together. *)
984 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
985 type ('x,'a) result = 'a tree option
986 type ('x,'a) result_exn = 'a tree
987 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
988 (* TreeT transformer *)
989 module T : functor (Wrapped : Monad.S) -> sig
990 type ('x,'a) result = ('x,'a tree option) Wrapped.result
991 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
992 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
993 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
994 (* note that second argument is an 'a tree?, not the more abstract 'a m *)
995 (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
996 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
997 val expose : ('x,'a) m -> ('x,'a tree option) Wrapped.m
1000 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1001 (* uses supplied plus and zero to copy t to its image under f *)
1002 let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
1004 | Some ts -> let rec loop ts = (match ts with
1007 (* recursive application of f may delete a branch *)
1008 plus (loop l) (loop r)
1010 module Base = struct
1011 type ('x,'a) m = 'a tree option
1012 type ('x,'a) result = 'a tree option
1013 type ('x,'a) result_exn = 'a tree
1014 let unit a = Some (Leaf a)
1016 (* satisfies Distrib *)
1017 let plus u v = match (u, v) with
1020 | Some us, Some vs -> Some (Node (us, vs))
1021 let bind u f = mapT f u zero plus
1023 let run_exn u = match u with
1024 | None -> failwith "no values"
1026 | Some (Leaf a) -> a
1027 | many -> failwith "multiple values"
1031 include Monad.Make(Base)
1032 module T(Wrapped : Monad.S) = struct
1033 module BaseT = struct
1034 include Monad.MakeT(struct
1035 module Wrapped = Wrapped
1036 type ('x,'a) m = ('x,'a tree option) Wrapped.m
1037 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1038 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1039 let zero () = Wrapped.unit None
1041 Wrapped.bind u (fun us ->
1042 Wrapped.bind v (fun vs ->
1043 Wrapped.unit (Base.plus us vs)))
1044 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1045 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1046 let run u = Wrapped.run u
1048 let w = Wrapped.bind u (fun t -> match t with
1049 | None -> Wrapped.zero ()
1050 | Some ts -> Wrapped.unit ts
1051 ) in Wrapped.run_exn w
1055 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus