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)
953 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
954 * let example1 () : int =
955 * Continuation_monad.(let v = reset (
956 * let u = shift (fun k -> unit (10 + 1))
957 * in u >>= fun x -> unit (100 + x)
958 * ) in let w = v >>= fun x -> unit (1000 + x)
961 * (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
963 * Continuation_monad.(let v = reset (
964 * let u = shift (fun k -> k (10 :: [1]))
965 * in u >>= fun x -> unit (100 :: x)
966 * ) in let w = v >>= fun x -> unit (1000 :: x)
969 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
971 * Continuation_monad.(let v = reset (
972 * let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
973 * in u >>= fun x -> unit (100 :: x)
974 * ) in let w = v >>= fun x -> unit (1000 :: x)
977 * (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
978 * (* not sure if this example can be typed without a sum-type *)
980 * (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
981 * let example5 () : int =
982 * Continuation_monad.(let v = reset (
983 * let u = shift (fun k -> k 1 >>= fun x -> k x)
984 * in u >>= fun x -> unit (10 + x)
985 * ) in let w = v >>= fun x -> unit (100 + x)
991 module Tree_monad : sig
992 (* We implement the type as `'a tree option` because it has a natural`plus`,
993 * and the rest of the library expects that `plus` and `zero` will come together. *)
994 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
995 type ('x,'a) result = 'a tree option
996 type ('x,'a) result_exn = 'a tree
997 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
998 (* TreeT transformer *)
999 module T : functor (Wrapped : Monad.S) -> sig
1000 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1001 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1002 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1003 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
1004 (* note that second argument is an 'a tree?, not the more abstract 'a m *)
1005 (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
1006 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
1009 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1010 (* uses supplied plus and zero to copy t to its image under f *)
1011 let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
1013 | Some ts -> let rec loop ts = (match ts with
1016 (* recursive application of f may delete a branch *)
1017 plus (loop l) (loop r)
1019 module Base = struct
1020 type ('x,'a) m = 'a tree option
1021 type ('x,'a) result = 'a tree option
1022 type ('x,'a) result_exn = 'a tree
1023 let unit a = Some (Leaf a)
1025 (* satisfies Distrib *)
1026 let plus u v = match (u, v) with
1029 | Some us, Some vs -> Some (Node (us, vs))
1030 let bind u f = mapT f u zero plus
1032 let run_exn u = match u with
1033 | None -> failwith "no values"
1035 | Some (Leaf a) -> a
1036 | many -> failwith "multiple values"
1040 include Monad.Make(Base)
1041 module T(Wrapped : Monad.S) = struct
1042 module BaseT = struct
1043 include Monad.MakeT(struct
1044 module Wrapped = Wrapped
1045 type ('x,'a) m = ('x,'a tree option) Wrapped.m
1046 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1047 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1048 let zero () = Wrapped.unit None
1050 Wrapped.bind u (fun us ->
1051 Wrapped.bind v (fun vs ->
1052 Wrapped.unit (Base.plus us vs)))
1053 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1054 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1055 let run u = Wrapped.run u
1057 let w = Wrapped.bind u (fun t -> match t with
1058 | None -> Wrapped.zero ()
1059 | Some ts -> Wrapped.unit ts
1060 ) in Wrapped.run_exn w
1064 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1069 module L = List_monad;;
1070 module R = Reader_monad(struct type env = int -> int end);;
1071 module S = State_monad(struct type store = int end);;
1072 module T = Tree_monad;;
1073 module LR = L.T(R);;
1074 module LS = L.T(S);;
1075 module TL = T.T(L);;
1076 module TR = T.T(R);;
1077 module TS = T.T(S);;
1078 module C = Continuation_monad
1079 module TC = T.T(C);;
1082 print_endline "=== test TreeT(...).distribute ==================";;
1084 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))));;
1086 let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
1089 - : int T.tree option * S.store =
1092 (T.Node (T.Leaf 2, T.Leaf 3),
1093 T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
1097 let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
1100 - : (int * S.store) T.tree option * S.store =
1103 (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
1104 T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
1108 let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
1109 TR.run_exn tr (fun i -> i+i);;
1111 - : int T.tree option =
1114 (T.Node (T.Leaf 4, T.Leaf 6),
1115 T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
1118 let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
1121 - : (int * int) TL.result =
1124 (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
1125 T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
1128 let l2 = [1;2;3;4;5];;
1129 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))));;
1131 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);;
1132 (* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
1134 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);;
1139 (T.Node (T.Leaf 10, T.Leaf 11),
1142 (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
1143 T.Node (T.Leaf 40, T.Leaf 41)),
1144 T.Node (T.Leaf 50, T.Leaf 51))))
1147 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;;
1149 - : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
1152 print_endline "=== test TreeT(Continuation).distribute ==================";;
1154 let id : 'z. 'z -> 'z = fun x -> x
1156 let example n : (int * int) =
1157 Continuation_monad.(let u = callcc (fun k ->
1158 (if n < 0 then k 0 else unit [n + 100])
1159 (* all of the following is skipped by k 0; the end type int is k's input type *)
1160 >>= fun [x] -> unit (x + 1)
1162 (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1163 >>= fun x -> unit (x, 0)
1167 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1168 let example1 () : int =
1169 Continuation_monad.(let v = reset (
1170 let u = shift (fun k -> unit (10 + 1))
1171 in u >>= fun x -> unit (100 + x)
1172 ) in let w = v >>= fun x -> unit (1000 + x)
1175 (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1177 Continuation_monad.(let v = reset (
1178 let u = shift (fun k -> k (10 :: [1]))
1179 in u >>= fun x -> unit (100 :: x)
1180 ) in let w = v >>= fun x -> unit (1000 :: x)
1183 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1185 Continuation_monad.(let v = reset (
1186 let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1187 in u >>= fun x -> unit (100 :: x)
1188 ) in let w = v >>= fun x -> unit (1000 :: x)
1191 (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1192 (* not sure if this example can be typed without a sum-type *)
1194 (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1195 let example5 () : int =
1196 Continuation_monad.(let v = reset (
1197 let u = shift (fun k -> k 1 >>= k)
1198 in u >>= fun x -> unit (10 + x)
1199 ) in let w = v >>= fun x -> unit (100 + x)
1204 print_endline "=== test bare Continuation ============";;
1206 (1011, 1111, 1111, 121);;
1207 (example1(), example2(), example3(), example5());;
1209 (example ~+10, example ~-10);;
1212 C.run_exn TC.(run (distribute df t1)) ic;;
1217 let initial_continuation = fun t -> t in
1218 TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
1223 (* count leaves, using continuation *)
1224 let initial_continuation = fun t -> 0 in
1225 TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
1228 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
1231 (* convert tree to list of leaves *)
1232 let initial_continuation = fun t -> [] in
1233 TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
1236 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
1239 (* square each leaf using continuation *)
1240 let initial_continuation = fun t -> t in
1241 TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
1244 testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
1248 (* replace leaves with list, using continuation *)
1249 let initial_continuation = fun t -> t in
1250 TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
1253 testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;
1255 print_endline "=== pa_monad's Continuation Tests ============";;
1257 (1, 5 = C.(run0 (unit 1 >>= fun x -> unit (x+4))) );;
1258 (2, 9 = C.(run0 (reset (unit 5 >>= fun x -> unit (x+4)))) );;
1259 (3, 9 = C.(run0 (reset (abort 5 >>= fun y -> unit (y+6)) >>= fun x -> unit (x+4))) );;
1260 (4, 9 = C.(run0 (reset (reset (abort 5 >>= fun y -> unit (y+6))) >>= fun x -> unit (x+4))) );;
1262 let c = reset(abort 5 >>= fun y -> unit (y+6))
1263 in reset(c >>= fun v1 -> abort 7 >>= fun v2 -> unit (v2+10) ) >>= fun x -> unit (x+20))) );;
1265 (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))) );;
1267 (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))) );;
1269 (12, ["a"] = C.(run0 (reset (shift (fun f -> f [] >>= fun t -> unit ("a"::t) ) >>= fun xv -> shift (fun _ -> unit xv)))) );;
1272 (0, 15 = C.(run0 (let f k = k 10 >>= fun v-> unit (v+100) in reset (callcc f >>= fun v -> unit (v+5)))) );;