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)
63 let undefined = Obj.magic ""
69 * This module contains factories that extend a base set of
70 * monadic definitions with a larger family of standard derived values.
75 * Signature extenders:
77 * MakeT :: TRANS (with Wrapped : S) -> custom sig
81 (* type of base definitions *)
82 module type BASE = sig
83 (* The only constraints we impose here on how the monadic type
84 * is implemented is that it have a single type parameter 'a. *)
87 type ('x,'a) result_exn
88 val unit : 'a -> ('x,'a) m
89 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
90 val run : ('x,'a) m -> ('x,'a) result
91 (* run_exn tries to provide a more ground-level result, but may fail *)
92 val run_exn : ('x,'a) m -> ('x,'a) result_exn
93 (* To simplify the library, we require every monad to supply a plus and zero. These obey the following laws:
97 * Additionally, they will obey one of the following laws:
98 * (Catch) plus (unit a) v === unit a
99 * (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
100 * When no natural zero is available, use `let zero () = Util.undefined
101 * The Make process automatically detects for zero >>= ..., and
102 * plus zero _, plus _ zero; it also substitutes zero for pattern-match failures.
104 val zero : unit -> ('x,'a) m
105 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
109 val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
110 val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
111 val join : ('x,('x,'a) m) m -> ('x,'a) m
112 val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
113 val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
114 val lift2 : ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
115 val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
116 val do_when : bool -> ('x,unit) m -> ('x,unit) m
117 val do_unless : bool -> ('x,unit) m -> ('x,unit) m
118 val forever : (unit -> ('x,'a) m) -> ('x,'b) m
119 val sequence : ('x,'a) m list -> ('x,'a list) m
120 val sequence_ : ('x,'a) m list -> ('x,unit) m
121 val guard : bool -> ('x,unit) m
122 val sum : ('x,'a) m list -> ('x,'a) m
125 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
127 let bind (u : ('x,'a) m) (f : 'a -> ('x,'b) m) : ('x,'b) m =
128 if u == Util.undefined then Util.undefined
129 else bind u (fun a -> try f a with Match_failure _ -> zero ())
131 if u == Util.undefined then v else if v == Util.undefined then u else plus u v
133 if u == Util.undefined then failwith "no zero" else run u
135 if u == Util.undefined then failwith "no zero" else run_exn u
137 let (>>) u v = u >>= fun _ -> v
138 let lift f u = u >>= fun a -> unit (f a)
139 (* lift is called listM, fmap, and <$> in Haskell *)
140 let join uu = uu >>= fun u -> u
141 (* u >>= f === join (lift f u) *)
142 let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
143 (* [f] <*> [x1,x2] = [f x1,f x2] *)
144 (* let apply u v = u >>= fun f -> lift f v *)
145 (* let apply = lift2 id *)
146 let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
147 (* let lift f u === apply (unit f) u *)
148 (* let lift2 f u v = apply (lift f u) v *)
149 let (>=>) f g = fun a -> f a >>= g
150 let do_when test u = if test then u else unit ()
151 let do_unless test u = if test then unit () else u
153 let rec loop () = uthunk () >>= fun _ -> loop ()
156 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
157 Util.fold_right op ms (unit [])
159 Util.fold_right (>>) ms (unit ())
161 (* Haskell defines these other operations combining lists and monads.
162 * We don't, but notice that M.mapM == ListT(M).distribute
163 * There's also a parallel TreeT(M).distribute *)
165 let mapM f alist = sequence (Util.map f alist)
166 let mapM_ f alist = sequence_ (Util.map f alist)
167 let rec filterM f lst = match lst with
169 | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
170 let forM alist f = mapM f alist
171 let forM_ alist f = mapM_ f alist
172 let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
173 let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
174 let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
175 let rec foldM f z lst = match lst with
177 | x::xs -> f z x >>= fun z' -> foldM f z' xs
178 let foldM_ f z xs = foldM f z xs >> unit ()
179 let replicateM n x = sequence (Util.replicate n x)
180 let replicateM_ n x = sequence_ (Util.replicate n x)
182 let guard test = if test then B.unit () else zero ()
183 let sum ms = Util.fold_right plus ms (zero ())
186 (* Signatures for MonadT *)
187 module type TRANS = sig
191 type ('x,'a) result_exn
192 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
193 val run : ('x,'a) m -> ('x,'a) result
194 val run_exn : ('x,'a) m -> ('x,'a) result_exn
195 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
196 (* lift/elevate laws:
197 * elevate (W.unit a) == unit a
198 * elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
200 val zero : unit -> ('x,'a) m
201 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
203 module MakeT(T : TRANS) = struct
206 let unit a = elevate (Wrapped.unit a)
208 let elevate = T.elevate
217 module Identity_monad : sig
218 (* expose only the implementation of type `'a result` *)
219 type ('x,'a) result = 'a
220 type ('x,'a) result_exn = 'a
221 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
225 type ('x,'a) result = 'a
226 type ('x,'a) result_exn = 'a
231 let zero () = Util.undefined
234 include Monad.Make(Base)
238 module Maybe_monad : sig
239 (* expose only the implementation of type `'a result` *)
240 type ('x,'a) result = 'a option
241 type ('x,'a) result_exn = 'a
242 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
243 (* MaybeT transformer *)
244 module T : functor (Wrapped : Monad.S) -> sig
245 type ('x,'a) result = ('x,'a option) Wrapped.result
246 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
247 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
248 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
252 type ('x,'a) m = 'a option
253 type ('x,'a) result = 'a option
254 type ('x,'a) result_exn = 'a
256 let bind u f = match u with Some a -> f a | None -> None
258 let run_exn u = match u with
260 | None -> failwith "no value"
262 (* satisfies Catch *)
263 let plus u v = match u with None -> v | _ -> u
265 include Monad.Make(Base)
266 module T(Wrapped : Monad.S) = struct
267 module Trans = struct
268 include Monad.MakeT(struct
269 module Wrapped = Wrapped
270 type ('x,'a) m = ('x,'a option) Wrapped.m
271 type ('x,'a) result = ('x,'a option) Wrapped.result
272 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
273 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
274 let bind u f = Wrapped.bind u (fun t -> match t with
276 | None -> Wrapped.unit None)
277 let run u = Wrapped.run u
279 let w = Wrapped.bind u (fun t -> match t with
280 | Some a -> Wrapped.unit a
281 | None -> failwith "no value")
283 let zero () = Wrapped.unit None
284 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
292 module List_monad : sig
293 (* declare additional operation, while still hiding implementation of type m *)
294 type ('x,'a) result = 'a list
295 type ('x,'a) result_exn = 'a
296 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
297 val permute : ('x,'a) m -> ('x,('x,'a) m) m
298 val select : ('x,'a) m -> ('x,'a * ('x,'a) m) m
299 (* ListT transformer *)
300 module T : functor (Wrapped : Monad.S) -> sig
301 type ('x,'a) result = ('x,'a list) Wrapped.result
302 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
303 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
304 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
305 (* note that second argument is an 'a list, not the more abstract 'a m *)
306 (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
307 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
309 val permute : 'a m -> 'a m m
310 val select : 'a m -> ('a * 'a m) m
315 type ('x,'a) m = 'a list
316 type ('x,'a) result = 'a list
317 type ('x,'a) result_exn = 'a
319 let bind u f = Util.concat_map f u
321 let run_exn u = match u with
322 | [] -> failwith "no values"
324 | many -> failwith "multiple values"
326 let plus = Util.append
328 include Monad.Make(Base)
329 (* let either u v = plus u v *)
330 (* insert 3 [1;2] ~~> [[3;1;2]; [1;3;2]; [1;2;3]] *)
332 plus (unit (a :: u)) (match u with
334 | x :: xs -> (insert a xs) >>= fun v -> unit (x :: v)
336 (* permute [1;2;3] ~~> [1;2;3]; [2;1;3]; [2;3;1]; [1;3;2]; [3;1;2]; [3;2;1] *)
337 let rec permute u = match u with
339 | x :: xs -> (permute xs) >>= (fun v -> insert x v)
340 (* select [1;2;3] ~~> [(1,[2;3]); (2,[1;3]), (3;[1;2])] *)
341 let rec select u = match u with
343 | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
345 module T(Wrapped : Monad.S) = struct
346 (* Wrapped.sequence ms ===
348 Wrapped.bind u (fun x ->
349 Wrapped.bind v (fun xs ->
350 Wrapped.unit (x :: xs)))
351 in Util.fold_right plus1 ms (Wrapped.unit []) *)
352 (* distribute === Wrapped.mapM; copies alist to its image under f *)
353 let distribute f alist = Wrapped.sequence (Util.map f alist)
355 include Monad.MakeT(struct
356 module Wrapped = Wrapped
357 type ('x,'a) m = ('x,'a list) Wrapped.m
358 type ('x,'a) result = ('x,'a list) Wrapped.result
359 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
360 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
362 Wrapped.bind u (fun ts ->
363 Wrapped.bind (distribute f ts) (fun tts ->
364 Wrapped.unit (Util.concat tts)))
365 let run u = Wrapped.run u
367 let w = Wrapped.bind u (fun ts -> match ts with
368 | [] -> failwith "no values"
369 | [a] -> Wrapped.unit a
370 | many -> failwith "multiple values"
371 ) in Wrapped.run_exn w
372 let zero () = Wrapped.unit []
374 Wrapped.bind u (fun us ->
375 Wrapped.bind v (fun vs ->
376 Wrapped.unit (base_plus us vs)))
379 let permute : 'a m -> 'a m m
380 let select : 'a m -> ('a * 'a m) m
386 (* must be parameterized on (struct type err = ... end) *)
387 module Error_monad(Err : sig
391 val zero : unit -> err
392 val plus : err -> err -> err
395 (* declare additional operations, while still hiding implementation of type m *)
397 type 'a error = Error of err | Success of 'a
398 type ('x,'a) result = 'a error
399 type ('x,'a) result_exn = 'a
400 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
401 val throw : err -> ('x,'a) m
402 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
403 (* ErrorT transformer *)
404 module T : functor (Wrapped : Monad.S) -> sig
405 type ('x,'a) result = ('x,'a) Wrapped.result
406 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
407 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
408 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
409 val throw : err -> ('x,'a) m
410 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
414 type 'a error = Error of err | Success of 'a
416 type ('x,'a) m = 'a error
417 type ('x,'a) result = 'a error
418 type ('x,'a) result_exn = 'a
419 let unit a = Success a
420 let bind u f = match u with
422 | Error e -> Error e (* input and output may be of different 'a types *)
424 let run_exn u = match u with
426 | Error e -> raise (Err.Exc e)
427 let zero () = Util.undefined
430 let zero () = Error Err.zero
431 let plus u v = match (u, v) with
433 (* to satisfy (Catch) laws, plus u zero = u, even if u = Error _
434 * otherwise, plus (Error _) v = v *)
435 | Error _, _ when v = zero -> u
437 | Error e1, Error e2 when u <> zero -> Error (Err.plus e1 e2)
441 include Monad.Make(Base)
442 (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
443 let throw e = Error e
444 let catch u handler = match u with
446 | Error e -> handler e
447 module T(Wrapped : Monad.S) = struct
448 include Monad.MakeT(struct
449 module Wrapped = Wrapped
450 type ('x,'a) m = ('x,'a error) Wrapped.m
451 type ('x,'a) result = ('x,'a) Wrapped.result
452 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
453 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
454 let bind u f = Wrapped.bind u (fun t -> match t with
456 | Error e -> Wrapped.unit (Error e))
458 let w = Wrapped.bind u (fun t -> match t with
459 | Success a -> Wrapped.unit a
460 | Error e -> Wrapped.zero ())
463 let w = Wrapped.bind u (fun t -> match t with
464 | Success a -> Wrapped.unit a
465 | Error e -> raise (Err.Exc e))
467 let plus u v = Wrapped.plus u v
468 let zero () = elevate (Wrapped.zero ())
470 let throw e = Wrapped.unit (Error e)
471 let catch u handler = Wrapped.bind u (fun t -> match t with
472 | Success _ -> Wrapped.unit t
473 | Error e -> handler e)
477 (* pre-define common instance of Error_monad *)
478 module Failure = Error_monad(struct
480 exception Exc = Failure
483 let plus s1 s2 = s1 ^ "\n" ^ s2
488 # EL.(run( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
489 - : int EL.result = [Failure.Error "bye"; Failure.Success 30]
490 # LE.(run( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
491 - : int LE.result = Failure.Error "bye"
492 # EL.(run_exn( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
493 Exception: Failure "bye".
494 # LE.(run_exn( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
495 Exception: Failure "bye".
497 # ES.(run( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
498 - : int Failure.error * S.store = (Failure.Error "bye", 1)
499 # SE.(run( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
500 - : (int * S.store) Failure.result = Failure.Error "bye"
501 # ES.(run_exn( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
502 Exception: Failure "bye".
503 # SE.(run_exn( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
504 Exception: Failure "bye".
508 (* must be parameterized on (struct type env = ... end) *)
509 module Reader_monad(Env : sig type env end) : sig
510 (* declare additional operations, while still hiding implementation of type m *)
512 type ('x,'a) result = env -> 'a
513 type ('x,'a) result_exn = env -> 'a
514 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
516 val asks : (env -> 'a) -> ('x,'a) m
517 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
518 (* ReaderT transformer *)
519 module T : functor (Wrapped : Monad.S) -> sig
520 type ('x,'a) result = env -> ('x,'a) Wrapped.result
521 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
522 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
523 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
525 val asks : (env -> 'a) -> ('x,'a) m
526 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
531 type ('x,'a) m = env -> 'a
532 type ('x,'a) result = env -> 'a
533 type ('x,'a) result_exn = env -> 'a
534 let unit a = fun e -> a
535 let bind u f = fun e -> let a = u e in let u' = f a in u' e
536 let run u = fun e -> u e
538 let zero () = Util.undefined
541 include Monad.Make(Base)
543 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
544 let local modifier u = fun e -> u (modifier e)
545 module T(Wrapped : Monad.S) = struct
546 module Trans = struct
547 module Wrapped = Wrapped
548 type ('x,'a) m = env -> ('x,'a) Wrapped.m
549 type ('x,'a) result = env -> ('x,'a) Wrapped.result
550 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
551 let elevate w = fun e -> w
552 let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
553 let run u = fun e -> Wrapped.run (u e)
554 let run_exn u = fun e -> Wrapped.run_exn (u e)
555 let plus u v = fun s -> Wrapped.plus (u s) (v s)
556 let zero () = elevate (Wrapped.zero ())
558 include Monad.MakeT(Trans)
559 let ask = fun e -> Wrapped.unit e
560 let local modifier u = fun e -> u (modifier e)
561 let asks selector = ask >>= (fun e ->
562 try unit (selector e)
563 with Not_found -> fun e -> Wrapped.zero ())
568 (* must be parameterized on (struct type store = ... end) *)
569 module State_monad(Store : sig type store end) : sig
570 (* declare additional operations, while still hiding implementation of type m *)
571 type store = Store.store
572 type ('x,'a) result = store -> 'a * store
573 type ('x,'a) result_exn = store -> 'a
574 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
575 val get : ('x,store) m
576 val gets : (store -> 'a) -> ('x,'a) m
577 val put : store -> ('x,unit) m
578 val puts : (store -> store) -> ('x,unit) m
579 (* StateT transformer *)
580 module T : functor (Wrapped : Monad.S) -> sig
581 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
582 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
583 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
584 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
585 val get : ('x,store) m
586 val gets : (store -> 'a) -> ('x,'a) m
587 val put : store -> ('x,unit) m
588 val puts : (store -> store) -> ('x,unit) m
591 type store = Store.store
593 type ('x,'a) m = store -> 'a * store
594 type ('x,'a) result = store -> 'a * store
595 type ('x,'a) result_exn = store -> 'a
596 let unit a = fun s -> (a, s)
597 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
598 let run u = fun s -> (u s)
599 let run_exn u = fun s -> fst (u s)
600 let zero () = Util.undefined
603 include Monad.Make(Base)
604 let get = fun s -> (s, s)
605 let gets viewer = fun s -> (viewer s, s) (* may fail *)
606 let put s = fun _ -> ((), s)
607 let puts modifier = fun s -> ((), modifier s)
608 module T(Wrapped : Monad.S) = struct
609 module Trans = struct
610 module Wrapped = Wrapped
611 type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
612 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
613 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
614 let elevate w = fun s ->
615 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
616 let bind u f = fun s ->
617 Wrapped.bind (u s) (fun (a, s') -> f a s')
618 let run u = fun s -> Wrapped.run (u s)
619 let run_exn u = fun s ->
620 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
622 let plus u v = fun s -> Wrapped.plus (u s) (v s)
623 let zero () = elevate (Wrapped.zero ())
625 include Monad.MakeT(Trans)
626 let get = fun s -> Wrapped.unit (s, s)
627 let gets viewer = fun s ->
628 try Wrapped.unit (viewer s, s)
629 with Not_found -> Wrapped.zero ()
630 let put s = fun _ -> Wrapped.unit ((), s)
631 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
635 (* State monad with different interface (structured store) *)
636 module Ref_monad(V : sig
641 type ('x,'a) result = 'a
642 type ('x,'a) result_exn = 'a
643 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
644 val newref : value -> ('x,ref) m
645 val deref : ref -> ('x,value) m
646 val change : ref -> value -> ('x,unit) m
647 (* RefT transformer *)
648 module T : functor (Wrapped : Monad.S) -> sig
649 type ('x,'a) result = ('x,'a) Wrapped.result
650 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
651 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
652 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
653 val newref : value -> ('x,ref) m
654 val deref : ref -> ('x,value) m
655 val change : ref -> value -> ('x,unit) m
660 module D = Map.Make(struct type t = ref let compare = compare end)
661 type dict = { next: ref; tree : value D.t }
662 let empty = { next = 0; tree = D.empty }
663 let alloc (value : value) (d : dict) =
664 (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
665 let read (key : ref) (d : dict) =
667 let write (key : ref) (value : value) (d : dict) =
668 { next = d.next; tree = D.add key value d.tree }
670 type ('x,'a) m = dict -> 'a * dict
671 type ('x,'a) result = 'a
672 type ('x,'a) result_exn = 'a
673 let unit a = fun s -> (a, s)
674 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
675 let run u = fst (u empty)
677 let zero () = Util.undefined
680 include Monad.Make(Base)
681 let newref value = fun s -> alloc value s
682 let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
683 let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
684 module T(Wrapped : Monad.S) = struct
685 module Trans = struct
686 module Wrapped = Wrapped
687 type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
688 type ('x,'a) result = ('x,'a) Wrapped.result
689 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
690 let elevate w = fun s ->
691 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
692 let bind u f = fun s ->
693 Wrapped.bind (u s) (fun (a, s') -> f a s')
695 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
698 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
700 let plus u v = fun s -> Wrapped.plus (u s) (v s)
701 let zero () = elevate (Wrapped.zero ())
703 include Monad.MakeT(Trans)
704 let newref value = fun s -> Wrapped.unit (alloc value s)
705 let deref key = fun s -> Wrapped.unit (read key s, s)
706 let change key value = fun s -> Wrapped.unit ((), write key value s)
711 (* must be parameterized on (struct type log = ... end) *)
712 module Writer_monad(Log : sig
715 val plus : log -> log -> log
717 (* declare additional operations, while still hiding implementation of type m *)
719 type ('x,'a) result = 'a * log
720 type ('x,'a) result_exn = 'a * log
721 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
722 val tell : log -> ('x,unit) m
723 val listen : ('x,'a) m -> ('x,'a * log) m
724 val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
725 (* val pass : ('x,'a * (log -> log)) m -> ('x,'a) m *)
726 val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
730 type ('x,'a) m = 'a * log
731 type ('x,'a) result = 'a * log
732 type ('x,'a) result_exn = 'a * log
733 let unit a = (a, Log.zero)
734 let bind (a, w) f = let (a', w') = f a in (a', Log.plus w w')
737 let zero () = Util.undefined
740 include Monad.Make(Base)
741 let tell entries = ((), entries) (* add entries to log *)
742 let listen (a, w) = ((a, w), w)
743 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
744 let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
745 let censor f u = pass (u >>= fun a -> unit (a, f))
748 (* pre-define simple Writer *)
749 module Writer1 = Writer_monad(struct
752 let plus s1 s2 = s1 ^ "\n" ^ s2
755 (* slightly more efficient Writer *)
756 module Writer2 = struct
757 include Writer_monad(struct
758 type log = string list
760 let plus w w' = Util.append w' w
762 let tell_string s = tell [s]
763 let tell entries = tell (Util.reverse entries)
764 let run u = let (a, w) = run u in (a, Util.reverse w)
769 module IO_monad : sig
770 (* declare additional operation, while still hiding implementation of type m *)
771 type ('x,'a) result = 'a
772 type ('x,'a) result_exn = 'a
773 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
774 val printf : ('a, unit, string, ('x,unit) m) format4 -> 'a
775 val print_string : string -> ('x,unit) m
776 val print_int : int -> ('x,unit) m
777 val print_hex : int -> ('x,unit) m
778 val print_bool : bool -> ('x,unit) m
781 type ('x,'a) m = { run : unit -> unit; value : 'a }
782 type ('x,'a) result = 'a
783 type ('x,'a) result_exn = 'a
784 let unit a = { run = (fun () -> ()); value = a }
785 let bind (a : ('x,'a) m) (f: 'a -> ('x,'b) m) : ('x,'b) m =
786 let fres = f a.value in
787 { run = (fun () -> a.run (); fres.run ()); value = fres.value }
788 let run a = let () = a.run () in a.value
790 let zero () = Util.undefined
793 include Monad.Make(Base)
795 Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
796 let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
797 let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
798 let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
799 let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
803 module Continuation_monad : sig
804 (* expose only the implementation of type `('r,'a) result` *)
806 type ('r,'a) result = ('r,'a) m
807 type ('r,'a) result_exn = ('a -> 'r) -> 'r
808 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
809 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
810 val reset : ('a,'a) m -> ('r,'a) m
811 val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
812 (* val abort : ('a,'a) m -> ('a,'b) m *)
813 val abort : 'a -> ('a,'b) m
814 val run0 : ('a,'a) m -> 'a
818 (* 'r is result type of whole computation *)
819 type ('r,'a) m = ('a -> 'r) -> 'r
820 type ('r,'a) result = ('a -> 'r) -> 'r
821 type ('r,'a) result_exn = ('r,'a) result
822 let unit a = (fun k -> k a)
823 let bind u f = (fun k -> (u) (fun a -> (f a) k))
826 let zero () = Util.undefined
829 include Monad.Make(Base)
830 let callcc f = (fun k ->
831 let usek a = (fun _ -> k a)
834 val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
835 val throw : ('a -> 'r) -> 'a -> ('r,'b) m
836 let callcc f = fun k -> f k k
837 let throw k a = fun _ -> k a
840 (* from http://www.haskell.org/haskellwiki/MonadCont_done_right
842 * reset :: (Monad m) => ContT a m a -> ContT r m a
843 * reset e = ContT $ \k -> runContT e return >>= k
845 * shift :: (Monad m) => ((a -> ContT r m b) -> ContT b m b) -> ContT b m a
846 * shift e = ContT $ \k ->
847 * runContT (e $ \v -> ContT $ \c -> k v >>= c) return *)
848 let reset u = unit ((u) id)
849 let shift f = (fun k -> (f (fun a -> unit (k a))) id)
850 (* let abort a = shift (fun _ -> a) *)
851 let abort a = shift (fun _ -> unit a)
852 let run0 (u : ('a,'a) m) = (u) id
858 * (define (example n)
859 * (let ([u (let/cc k ; type int -> int pair
860 * (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
861 * (+ 1 (car v))))]) ; int
862 * (cons u 0))) ; int pair
863 * ; (example 10) ~~> '(111 . 0)
864 * ; (example -10) ~~> '(0 . 0)
867 * let example n : (int * int) =
868 * Continuation_monad.(let u = callcc (fun k ->
869 * (if n < 0 then k 0 else unit [n + 100])
870 * (* all of the following is skipped by k 0; the end type int is k's input type *)
871 * >>= fun [x] -> unit (x + 1)
873 * (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
874 * >>= fun x -> unit (x, 0)
878 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
879 * let example1 () : int =
880 * Continuation_monad.(let v = reset (
881 * let u = shift (fun k -> unit (10 + 1))
882 * in u >>= fun x -> unit (100 + x)
883 * ) in let w = v >>= fun x -> unit (1000 + x)
886 * (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
888 * Continuation_monad.(let v = reset (
889 * let u = shift (fun k -> k (10 :: [1]))
890 * in u >>= fun x -> unit (100 :: x)
891 * ) in let w = v >>= fun x -> unit (1000 :: x)
894 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
896 * Continuation_monad.(let v = reset (
897 * let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
898 * in u >>= fun x -> unit (100 :: x)
899 * ) in let w = v >>= fun x -> unit (1000 :: x)
902 * (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
903 * (* not sure if this example can be typed without a sum-type *)
905 * (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
906 * let example5 () : int =
907 * Continuation_monad.(let v = reset (
908 * let u = shift (fun k -> k 1 >>= fun x -> k x)
909 * in u >>= fun x -> unit (10 + x)
910 * ) in let w = v >>= fun x -> unit (100 + x)
916 module Leaf_monad : sig
917 (* We implement the type as `'a tree option` because it has a natural`plus`,
918 * and the rest of the library expects that `plus` and `zero` will come together. *)
919 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
920 type ('x,'a) result = 'a tree option
921 type ('x,'a) result_exn = 'a tree
922 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
923 (* LeafT transformer *)
924 module T : functor (Wrapped : Monad.S) -> sig
925 type ('x,'a) result = ('x,'a tree option) Wrapped.result
926 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
927 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
928 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
929 (* note that second argument is an 'a tree?, not the more abstract 'a m *)
930 (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
931 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
934 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
935 (* uses supplied plus and zero to copy t to its image under f *)
936 let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
938 | Some ts -> let rec loop ts = (match ts with
941 (* recursive application of f may delete a branch *)
942 plus (loop l) (loop r)
945 type ('x,'a) m = 'a tree option
946 type ('x,'a) result = 'a tree option
947 type ('x,'a) result_exn = 'a tree
948 let unit a = Some (Leaf a)
950 let plus u v = match (u, v) with
953 | Some us, Some vs -> Some (Node (us, vs))
954 let bind u f = mapT f u zero plus
956 let run_exn u = match u with
957 | None -> failwith "no values"
960 | many -> failwith "multiple values"
964 include Monad.Make(Base)
967 module T(Wrapped : Monad.S) = struct
968 module Trans = struct
969 include Monad.MakeT(struct
970 module Wrapped = Wrapped
971 type ('x,'a) m = ('x,'a tree option) Wrapped.m
972 type ('x,'a) result = ('x,'a tree option) Wrapped.result
973 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
974 let zero () = Wrapped.unit None
976 Wrapped.bind u (fun us ->
977 Wrapped.bind v (fun vs ->
978 Wrapped.unit (base_plus us vs)))
979 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
980 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
981 let run u = Wrapped.run u
983 let w = Wrapped.bind u (fun t -> match t with
984 | None -> failwith "no values"
985 | Some ts -> Wrapped.unit ts)
990 (* let distribute f t = mapT (fun a -> a) (base_lift (fun a -> elevate (f a)) t) zero plus *)
991 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
996 module L = List_monad;;
997 module R = Reader_monad(struct type env = int -> int end);;
998 module S = State_monad(struct type store = int end);;
999 module T = Leaf_monad;;
1000 module LR = L.T(R);;
1001 module LS = L.T(S);;
1002 module TL = T.T(L);;
1003 module TR = T.T(R);;
1004 module TS = T.T(S);;
1005 module C = Continuation_monad
1006 module TC = T.T(C);;
1009 print_endline "=== test Leaf(...).distribute ==================";;
1011 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))));;
1013 let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
1016 - : int T.tree option * S.store =
1019 (T.Node (T.Leaf 2, T.Leaf 3),
1020 T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
1024 let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
1027 - : (int * S.store) T.tree option * S.store =
1030 (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
1031 T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
1035 let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
1036 TR.run_exn tr (fun i -> i+i);;
1038 - : int T.tree option =
1041 (T.Node (T.Leaf 4, T.Leaf 6),
1042 T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
1045 let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
1048 - : (int * int) TL.result =
1051 (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
1052 T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
1055 let l2 = [1;2;3;4;5];;
1056 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))));;
1058 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);;
1059 (* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
1061 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);;
1066 (T.Node (T.Leaf 10, T.Leaf 11),
1069 (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
1070 T.Node (T.Leaf 40, T.Leaf 41)),
1071 T.Node (T.Leaf 50, T.Leaf 51))))
1074 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;;
1076 - : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
1079 print_endline "=== test Leaf(Continuation).distribute ==================";;
1081 let id : 'z. 'z -> 'z = fun x -> x
1083 let example n : (int * int) =
1084 Continuation_monad.(let u = callcc (fun k ->
1085 (if n < 0 then k 0 else unit [n + 100])
1086 (* all of the following is skipped by k 0; the end type int is k's input type *)
1087 >>= fun [x] -> unit (x + 1)
1089 (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1090 >>= fun x -> unit (x, 0)
1094 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1095 let example1 () : int =
1096 Continuation_monad.(let v = reset (
1097 let u = shift (fun k -> unit (10 + 1))
1098 in u >>= fun x -> unit (100 + x)
1099 ) in let w = v >>= fun x -> unit (1000 + x)
1102 (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1104 Continuation_monad.(let v = reset (
1105 let u = shift (fun k -> k (10 :: [1]))
1106 in u >>= fun x -> unit (100 :: x)
1107 ) in let w = v >>= fun x -> unit (1000 :: x)
1110 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1112 Continuation_monad.(let v = reset (
1113 let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1114 in u >>= fun x -> unit (100 :: x)
1115 ) in let w = v >>= fun x -> unit (1000 :: x)
1118 (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1119 (* not sure if this example can be typed without a sum-type *)
1121 (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1122 let example5 () : int =
1123 Continuation_monad.(let v = reset (
1124 let u = shift (fun k -> k 1 >>= k)
1125 in u >>= fun x -> unit (10 + x)
1126 ) in let w = v >>= fun x -> unit (100 + x)
1131 print_endline "=== test bare Continuation ============";;
1133 (1011, 1111, 1111, 121);;
1134 (example1(), example2(), example3(), example5());;
1136 (example ~+10, example ~-10);;
1139 C.run_exn TC.(run (distribute df t1)) ic;;
1144 let initial_continuation = fun t -> t in
1145 TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
1150 (* count leaves, using continuation *)
1151 let initial_continuation = fun t -> 0 in
1152 TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
1155 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
1158 (* convert tree to list of leaves *)
1159 let initial_continuation = fun t -> [] in
1160 TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
1163 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
1166 (* square each leaf using continuation *)
1167 let initial_continuation = fun t -> t in
1168 TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
1171 testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
1175 (* replace leaves with list, using continuation *)
1176 let initial_continuation = fun t -> t in
1177 TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
1180 testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;
1182 print_endline "=== pa_monad's Continuation Tests ============";;
1184 (1, 5 = C.(run0 (unit 1 >>= fun x -> unit (x+4))) );;
1185 (2, 9 = C.(run0 (reset (unit 5 >>= fun x -> unit (x+4)))) );;
1186 (3, 9 = C.(run0 (reset (abort 5 >>= fun y -> unit (y+6)) >>= fun x -> unit (x+4))) );;
1187 (4, 9 = C.(run0 (reset (reset (abort 5 >>= fun y -> unit (y+6))) >>= fun x -> unit (x+4))) );;
1189 let c = reset(abort 5 >>= fun y -> unit (y+6))
1190 in reset(c >>= fun v1 -> abort 7 >>= fun v2 -> unit (v2+10) ) >>= fun x -> unit (x+20))) );;
1192 (7, 117 = C.(run0 (reset (shift (fun sk -> sk 3 >>= sk >>= fun v3 -> unit (v3+100) ) >>= fun v1 -> unit (v1+2)) >>= fun x -> unit (x+10))) );;
1194 (8, 115 = C.(run0 (reset (shift (fun sk -> sk 3 >>= fun v3 -> unit (v3+100)) >>= fun v1 -> unit (v1+2)) >>= fun x -> unit (x+10))) );;
1196 (12, ["a"] = C.(run0 (reset (shift (fun f -> f [] >>= fun t -> unit ("a"::t) ) >>= fun xv -> shift (fun _ -> unit xv)))) );;
1199 (0, 15 = C.(run0 (let f k = k 10 >>= fun v-> unit (v+100) in reset (callcc f >>= fun v -> unit (v+5)))) );;