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).
59 (* Some library functions used below. *)
61 let fold_right = List.fold_right
63 let append = List.append
64 let reverse = List.rev
65 let concat = List.concat
66 let concat_map f lst = List.concat (List.map f lst)
67 (* let zip = List.combine *)
68 let unzip = List.split
69 let zip_with = List.map2
70 let replicate len fill =
72 if n == 0 then accu else loop (pred n) (fill :: accu)
74 (* Dirty hack to be a default polymorphic zero.
75 * To implement this cleanly, monads without a natural zero
76 * should always wrap themselves in an option layer (see Leaf_monad). *)
77 let undef = Obj.magic (fun () -> raise Undefined)
83 * This module contains factories that extend a base set of
84 * monadic definitions with a larger family of standard derived values.
89 * Signature extenders:
91 * MakeT :: BASET (with Wrapped : S) -> result sig not declared
95 (* type of base definitions *)
96 module type BASE = sig
97 (* We make all monadic types doubly-parameterized so that they
98 * can layer nicely with Continuation, which needs the second
102 type ('x,'a) result_exn
103 val unit : 'a -> ('x,'a) m
104 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
105 val run : ('x,'a) m -> ('x,'a) result
106 (* run_exn tries to provide a more ground-level result, but may fail *)
107 val run_exn : ('x,'a) m -> ('x,'a) result_exn
108 (* To simplify the library, we require every monad to supply a plus and zero. These obey the following laws:
109 * zero >>= f === zero
112 * Additionally, they will obey one of the following laws:
113 * (Catch) plus (unit a) v === unit a
114 * (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
115 * When no natural zero is available, use `let zero () = Util.undef`.
116 * The Make functor automatically detects for zero >>= ..., and
117 * plus zero _, plus _ zero; it also substitutes zero for pattern-match failures.
119 val zero : unit -> ('x,'a) m
120 (* zero has to be thunked to ensure results are always poly enough *)
121 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
125 val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
126 val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
127 val join : ('x,('x,'a) m) m -> ('x,'a) m
128 val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
129 val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
130 val lift2 : ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
131 val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
132 val do_when : bool -> ('x,unit) m -> ('x,unit) m
133 val do_unless : bool -> ('x,unit) m -> ('x,unit) m
134 val forever : (unit -> ('x,'a) m) -> ('x,'b) m
135 val sequence : ('x,'a) m list -> ('x,'a list) m
136 val sequence_ : ('x,'a) m list -> ('x,unit) m
137 val guard : bool -> ('x,unit) m
138 val sum : ('x,'a) m list -> ('x,'a) m
141 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
143 let bind (u : ('x,'a) m) (f : 'a -> ('x,'b) m) : ('x,'b) m =
144 if u == Util.undef then Util.undef
145 else B.bind u (fun a -> try f a with Match_failure _ -> zero ())
147 if u == Util.undef then v else if v == Util.undef then u else B.plus u v
149 if u == Util.undef then raise Undefined else B.run u
151 if u == Util.undef then raise Undefined else B.run_exn u
153 (* expressions after >> will be evaluated before they're passed to
154 * bind, so you can't do `zero () >> assert false`
155 * this works though: `zero () >>= fun _ -> assert false`
157 let (>>) u v = u >>= fun _ -> v
158 let lift f u = u >>= fun a -> unit (f a)
159 (* lift is called listM, fmap, and <$> in Haskell *)
160 let join uu = uu >>= fun u -> u
161 (* u >>= f === join (lift f u) *)
162 let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
163 (* [f] <*> [x1,x2] = [f x1,f x2] *)
164 (* let apply u v = u >>= fun f -> lift f v *)
165 (* let apply = lift2 id *)
166 let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
167 (* let lift f u === apply (unit f) u *)
168 (* let lift2 f u v = apply (lift f u) v *)
169 let (>=>) f g = fun a -> f a >>= g
170 let do_when test u = if test then u else unit ()
171 let do_unless test u = if test then unit () else u
172 (* A Haskell-like version works:
173 let rec forever uthunk = uthunk () >>= fun _ -> forever uthunk
174 * but the recursive call is not in tail position so this can stack overflow. *)
177 let id result = result in
178 let kcell = ref id in
180 let result = uthunk (kcell := id) >>= chained
183 kcell := loop; z (* we use z only for its polymorphism *)
185 (* Reimplementations of the preceding using a hand-rolled State or StateT
186 can also stack overflow. *)
188 let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
189 Util.fold_right op ms (unit [])
191 Util.fold_right (>>) ms (unit ())
193 (* Haskell defines these other operations combining lists and monads.
194 * We don't, but notice that M.mapM == ListT(M).distribute
195 * There's also a parallel TreeT(M).distribute *)
197 let mapM f alist = sequence (Util.map f alist)
198 let mapM_ f alist = sequence_ (Util.map f alist)
199 let rec filterM f lst = match lst with
201 | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
202 let forM alist f = mapM f alist
203 let forM_ alist f = mapM_ f alist
204 let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
205 let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
206 let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
207 let rec foldM f z lst = match lst with
209 | x::xs -> f z x >>= fun z' -> foldM f z' xs
210 let foldM_ f z xs = foldM f z xs >> unit ()
211 let replicateM n x = sequence (Util.replicate n x)
212 let replicateM_ n x = sequence_ (Util.replicate n x)
214 let guard test = if test then B.unit () else zero ()
215 let sum ms = Util.fold_right plus ms (zero ())
218 (* Signatures for MonadT *)
219 module type BASET = sig
223 type ('x,'a) result_exn
224 val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
225 val run : ('x,'a) m -> ('x,'a) result
226 val run_exn : ('x,'a) m -> ('x,'a) result_exn
227 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
228 (* lift/elevate laws:
229 * elevate (W.unit a) == unit a
230 * elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
232 val zero : unit -> ('x,'a) m
233 val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
235 module MakeT(T : BASET) = struct
238 let unit a = elevate (Wrapped.unit a)
240 let elevate = T.elevate
249 module Identity_monad : sig
250 (* expose only the implementation of type `'a result` *)
251 type ('x,'a) result = 'a
252 type ('x,'a) result_exn = 'a
253 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
257 type ('x,'a) result = 'a
258 type ('x,'a) result_exn = 'a
263 let zero () = Util.undef
266 include Monad.Make(Base)
270 module Maybe_monad : sig
271 (* expose only the implementation of type `'a result` *)
272 type ('x,'a) result = 'a option
273 type ('x,'a) result_exn = 'a
274 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
275 (* MaybeT transformer *)
276 module T : functor (Wrapped : Monad.S) -> sig
277 type ('x,'a) result = ('x,'a option) Wrapped.result
278 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
279 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
280 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
284 type ('x,'a) m = 'a option
285 type ('x,'a) result = 'a option
286 type ('x,'a) result_exn = 'a
288 let bind u f = match u with Some a -> f a | None -> None
290 let run_exn u = match u with
292 | None -> failwith "no value"
294 (* satisfies Catch *)
295 let plus u v = match u with None -> v | _ -> u
297 include Monad.Make(Base)
298 module T(Wrapped : Monad.S) = struct
299 module BaseT = struct
300 include Monad.MakeT(struct
301 module Wrapped = Wrapped
302 type ('x,'a) m = ('x,'a option) Wrapped.m
303 type ('x,'a) result = ('x,'a option) Wrapped.result
304 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
305 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
306 let bind u f = Wrapped.bind u (fun t -> match t with
308 | None -> Wrapped.unit None)
309 let run u = Wrapped.run u
311 let w = Wrapped.bind u (fun t -> match t with
312 | Some a -> Wrapped.unit a
313 | None -> Wrapped.zero ()
314 ) in Wrapped.run_exn w
315 let zero () = Wrapped.unit None
316 let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
324 module List_monad : sig
325 (* declare additional operation, while still hiding implementation of type m *)
326 type ('x,'a) result = 'a list
327 type ('x,'a) result_exn = 'a
328 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
329 val permute : ('x,'a) m -> ('x,('x,'a) m) m
330 val select : ('x,'a) m -> ('x,'a * ('x,'a) m) m
331 (* ListT transformer *)
332 module T : functor (Wrapped : Monad.S) -> sig
333 type ('x,'a) result = ('x,'a list) Wrapped.result
334 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
335 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
336 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
337 (* note that second argument is an 'a list, not the more abstract 'a m *)
338 (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
339 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
341 val permute : 'a m -> 'a m m
342 val select : 'a m -> ('a * 'a m) m
347 type ('x,'a) m = 'a list
348 type ('x,'a) result = 'a list
349 type ('x,'a) result_exn = 'a
351 let bind u f = Util.concat_map f u
353 let run_exn u = match u with
354 | [] -> failwith "no values"
356 | many -> failwith "multiple values"
358 (* satisfies Distrib *)
359 let plus = Util.append
361 include Monad.Make(Base)
362 (* let either u v = plus u v *)
363 (* insert 3 [1;2] ~~> [[3;1;2]; [1;3;2]; [1;2;3]] *)
365 plus (unit (a :: u)) (match u with
367 | x :: xs -> (insert a xs) >>= fun v -> unit (x :: v)
369 (* permute [1;2;3] ~~> [1;2;3]; [2;1;3]; [2;3;1]; [1;3;2]; [3;1;2]; [3;2;1] *)
370 let rec permute u = match u with
372 | x :: xs -> (permute xs) >>= (fun v -> insert x v)
373 (* select [1;2;3] ~~> [(1,[2;3]); (2,[1;3]), (3;[1;2])] *)
374 let rec select u = match u with
376 | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
377 module T(Wrapped : Monad.S) = struct
378 (* Wrapped.sequence ms ===
380 Wrapped.bind u (fun x ->
381 Wrapped.bind v (fun xs ->
382 Wrapped.unit (x :: xs)))
383 in Util.fold_right plus1 ms (Wrapped.unit []) *)
384 (* distribute === Wrapped.mapM; copies alist to its image under f *)
385 let distribute f alist = Wrapped.sequence (Util.map f alist)
387 include Monad.MakeT(struct
388 module Wrapped = Wrapped
389 type ('x,'a) m = ('x,'a list) Wrapped.m
390 type ('x,'a) result = ('x,'a list) Wrapped.result
391 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
392 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
394 Wrapped.bind u (fun ts ->
395 Wrapped.bind (distribute f ts) (fun tts ->
396 Wrapped.unit (Util.concat tts)))
397 let run u = Wrapped.run u
399 let w = Wrapped.bind u (fun ts -> match ts with
400 | [] -> Wrapped.zero ()
401 | [a] -> Wrapped.unit a
402 | many -> Wrapped.zero ()
403 ) in Wrapped.run_exn w
404 let zero () = Wrapped.unit []
406 Wrapped.bind u (fun us ->
407 Wrapped.bind v (fun vs ->
408 Wrapped.unit (Base.plus us vs)))
411 let permute : 'a m -> 'a m m
412 let select : 'a m -> ('a * 'a m) m
418 # LL.(run(plus (unit 1) (unit 2) >>= fun i -> plus (unit i) (unit(10*i)) ));;
419 - : ('_a, int) LL.result = [[1; 10; 2; 20]]
420 # LL.(run(plus (unit 1) (unit 2) >>= fun i -> elevate L.(plus (unit i) (unit(10*i)) )));;
421 - : ('_a, int) LL.result = [[1; 2]; [1; 20]; [10; 2]; [10; 20]]
425 (* must be parameterized on (struct type err = ... end) *)
426 module Error_monad(Err : sig
430 val zero : unit -> err
431 val plus : err -> err -> err
434 (* declare additional operations, while still hiding implementation of type m *)
436 type 'a error = Error of err | Success of 'a
437 type ('x,'a) result = 'a error
438 type ('x,'a) result_exn = 'a
439 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
440 val throw : err -> ('x,'a) m
441 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
442 (* ErrorT transformer *)
443 module T : functor (Wrapped : Monad.S) -> sig
444 type ('x,'a) result = ('x,'a) Wrapped.result
445 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
446 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
447 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
448 val throw : err -> ('x,'a) m
449 val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
453 type 'a error = Error of err | Success of 'a
455 type ('x,'a) m = 'a error
456 type ('x,'a) result = 'a error
457 type ('x,'a) result_exn = 'a
458 let unit a = Success a
459 let bind u f = match u with
461 | Error e -> Error e (* input and output may be of different 'a types *)
463 let run_exn u = match u with
465 | Error e -> raise (Err.Exc e)
466 let zero () = Util.undef
467 (* satisfies Catch *)
468 let plus u v = match u with
470 | Error _ -> if v == Util.undef then u else v
472 include Monad.Make(Base)
473 (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
474 let throw e = Error e
475 let catch u handler = match u with
477 | Error e -> handler e
478 module T(Wrapped : Monad.S) = struct
479 include Monad.MakeT(struct
480 module Wrapped = Wrapped
481 type ('x,'a) m = ('x,'a error) Wrapped.m
482 type ('x,'a) result = ('x,'a) Wrapped.result
483 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
484 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
485 let bind u f = Wrapped.bind u (fun t -> match t with
487 | Error e -> Wrapped.unit (Error e))
489 let w = Wrapped.bind u (fun t -> match t with
490 | Success a -> Wrapped.unit a
491 | Error e -> Wrapped.zero ()
494 let w = Wrapped.bind u (fun t -> match t with
495 | Success a -> Wrapped.unit a
496 | Error e -> raise (Err.Exc e))
498 let plus u v = Wrapped.plus u v
499 let zero () = Wrapped.zero () (* elevate (Wrapped.zero ()) *)
501 let throw e = Wrapped.unit (Error e)
502 let catch u handler = Wrapped.bind u (fun t -> match t with
503 | Success _ -> Wrapped.unit t
504 | Error e -> handler e)
508 (* pre-define common instance of Error_monad *)
509 module Failure = Error_monad(struct
511 exception Exc = Failure
514 let plus s1 s2 = s1 ^ "\n" ^ s2
519 # EL.(run( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
520 - : int EL.result = [Failure.Error "bye"; Failure.Success 30]
521 # LE.(run( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
522 - : int LE.result = Failure.Error "bye"
523 # EL.(run_exn( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
524 Exception: Failure "bye".
525 # LE.(run_exn( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
526 Exception: Failure "bye".
528 # ES.(run( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
529 - : int Failure.error * S.store = (Failure.Error "bye", 1)
530 # SE.(run( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
531 - : (int * S.store) Failure.result = Failure.Error "bye"
532 # ES.(run_exn( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
533 Exception: Failure "bye".
534 # SE.(run_exn( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
535 Exception: Failure "bye".
539 (* must be parameterized on (struct type env = ... end) *)
540 module Reader_monad(Env : sig type env end) : sig
541 (* declare additional operations, while still hiding implementation of type m *)
543 type ('x,'a) result = env -> 'a
544 type ('x,'a) result_exn = env -> 'a
545 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
547 val asks : (env -> 'a) -> ('x,'a) m
548 (* lookup i == `fun e -> e i` would assume env is a functional type *)
549 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
550 (* ReaderT transformer *)
551 module T : functor (Wrapped : Monad.S) -> sig
552 type ('x,'a) result = env -> ('x,'a) Wrapped.result
553 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
554 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
555 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
557 val asks : (env -> 'a) -> ('x,'a) m
558 val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
563 type ('x,'a) m = env -> 'a
564 type ('x,'a) result = env -> 'a
565 type ('x,'a) result_exn = env -> 'a
566 let unit a = fun e -> a
567 let bind u f = fun e -> let a = u e in let u' = f a in u' e
568 let run u = fun e -> u e
570 let zero () = Util.undef
573 include Monad.Make(Base)
575 let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
576 let local modifier u = fun e -> u (modifier e)
577 module T(Wrapped : Monad.S) = struct
578 module BaseT = struct
579 module Wrapped = Wrapped
580 type ('x,'a) m = env -> ('x,'a) Wrapped.m
581 type ('x,'a) result = env -> ('x,'a) Wrapped.result
582 type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
583 let elevate w = fun e -> w
584 let bind u f = fun e -> Wrapped.bind (u e) (fun a -> f a e)
585 let run u = fun e -> Wrapped.run (u e)
586 let run_exn u = fun e -> Wrapped.run_exn (u e)
587 (* satisfies Distrib *)
588 let plus u v = fun e -> Wrapped.plus (u e) (v e)
589 let zero () = fun e -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
591 include Monad.MakeT(BaseT)
592 let ask = Wrapped.unit
593 let local modifier u = fun e -> u (modifier e)
594 let asks selector = ask >>= (fun e ->
595 try unit (selector e)
596 with Not_found -> fun e -> Wrapped.zero ())
601 (* must be parameterized on (struct type store = ... end) *)
602 module State_monad(Store : sig type store end) : sig
603 (* declare additional operations, while still hiding implementation of type m *)
604 type store = Store.store
605 type ('x,'a) result = store -> 'a * store
606 type ('x,'a) result_exn = store -> 'a
607 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
608 val get : ('x,store) m
609 val gets : (store -> 'a) -> ('x,'a) m
610 val put : store -> ('x,unit) m
611 val puts : (store -> store) -> ('x,unit) m
612 (* StateT transformer *)
613 module T : functor (Wrapped : Monad.S) -> sig
614 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
615 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
616 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
617 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
618 val get : ('x,store) m
619 val gets : (store -> 'a) -> ('x,'a) m
620 val put : store -> ('x,unit) m
621 val puts : (store -> store) -> ('x,unit) m
624 type store = Store.store
626 type ('x,'a) m = store -> 'a * store
627 type ('x,'a) result = store -> 'a * store
628 type ('x,'a) result_exn = store -> 'a
629 let unit a = fun s -> (a, s)
630 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
631 let run u = fun s -> (u s)
632 let run_exn u = fun s -> fst (u s)
633 let zero () = Util.undef
636 include Monad.Make(Base)
637 let get = fun s -> (s, s)
638 let gets viewer = fun s -> (viewer s, s) (* may fail *)
639 let put s = fun _ -> ((), s)
640 let puts modifier = fun s -> ((), modifier s)
641 module T(Wrapped : Monad.S) = struct
642 module BaseT = struct
643 module Wrapped = Wrapped
644 type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
645 type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
646 type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
647 let elevate w = fun s ->
648 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
649 let bind u f = fun s ->
650 Wrapped.bind (u s) (fun (a, s') -> f a s')
651 let run u = fun s -> Wrapped.run (u s)
652 let run_exn u = fun s ->
653 let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
655 (* satisfies Distrib *)
656 let plus u v = fun s -> Wrapped.plus (u s) (v s)
657 let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
659 include Monad.MakeT(BaseT)
660 let get = fun s -> Wrapped.unit (s, s)
661 let gets viewer = fun s ->
662 try Wrapped.unit (viewer s, s)
663 with Not_found -> Wrapped.zero ()
664 let put s = fun _ -> Wrapped.unit ((), s)
665 let puts modifier = fun s -> Wrapped.unit ((), modifier s)
669 (* State monad with different interface (structured store) *)
670 module Ref_monad(V : sig
675 type ('x,'a) result = 'a
676 type ('x,'a) result_exn = 'a
677 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
678 val newref : value -> ('x,ref) m
679 val deref : ref -> ('x,value) m
680 val change : ref -> value -> ('x,unit) m
681 (* RefT transformer *)
682 module T : functor (Wrapped : Monad.S) -> sig
683 type ('x,'a) result = ('x,'a) Wrapped.result
684 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
685 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
686 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
687 val newref : value -> ('x,ref) m
688 val deref : ref -> ('x,value) m
689 val change : ref -> value -> ('x,unit) m
694 module D = Map.Make(struct type t = ref let compare = compare end)
695 type dict = { next: ref; tree : value D.t }
696 let empty = { next = 0; tree = D.empty }
697 let alloc (value : value) (d : dict) =
698 (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
699 let read (key : ref) (d : dict) =
701 let write (key : ref) (value : value) (d : dict) =
702 { next = d.next; tree = D.add key value d.tree }
704 type ('x,'a) m = dict -> 'a * dict
705 type ('x,'a) result = 'a
706 type ('x,'a) result_exn = 'a
707 let unit a = fun s -> (a, s)
708 let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
709 let run u = fst (u empty)
711 let zero () = Util.undef
714 include Monad.Make(Base)
715 let newref value = fun s -> alloc value s
716 let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
717 let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
718 module T(Wrapped : Monad.S) = struct
719 module BaseT = struct
720 module Wrapped = Wrapped
721 type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
722 type ('x,'a) result = ('x,'a) Wrapped.result
723 type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
724 let elevate w = fun s ->
725 Wrapped.bind w (fun a -> Wrapped.unit (a, s))
726 let bind u f = fun s ->
727 Wrapped.bind (u s) (fun (a, s') -> f a s')
729 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
732 let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
734 (* satisfies Distrib *)
735 let plus u v = fun s -> Wrapped.plus (u s) (v s)
736 let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
738 include Monad.MakeT(BaseT)
739 let newref value = fun s -> Wrapped.unit (alloc value s)
740 let deref key = fun s -> Wrapped.unit (read key s, s)
741 let change key value = fun s -> Wrapped.unit ((), write key value s)
746 (* must be parameterized on (struct type log = ... end) *)
747 module Writer_monad(Log : sig
750 val plus : log -> log -> log
752 (* declare additional operations, while still hiding implementation of type m *)
754 type ('x,'a) result = 'a * log
755 type ('x,'a) result_exn = 'a * log
756 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
757 val tell : log -> ('x,unit) m
758 val listen : ('x,'a) m -> ('x,'a * log) m
759 val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
760 (* val pass : ('x,'a * (log -> log)) m -> ('x,'a) m *)
761 val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
762 (* WriterT transformer *)
763 module T : functor (Wrapped : Monad.S) -> sig
764 type ('x,'a) result = ('x,'a * log) Wrapped.result
765 type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
766 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
767 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
768 val tell : log -> ('x,unit) m
769 val listen : ('x,'a) m -> ('x,'a * log) m
770 val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
771 val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
776 type ('x,'a) m = 'a * log
777 type ('x,'a) result = 'a * log
778 type ('x,'a) result_exn = 'a * log
779 let unit a = (a, Log.zero)
780 let bind (a, w) f = let (b, w') = f a in (b, Log.plus w w')
783 let zero () = Util.undef
786 include Monad.Make(Base)
787 let tell entries = ((), entries) (* add entries to log *)
788 let listen (a, w) = ((a, w), w)
789 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
790 let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
791 let censor f u = pass (u >>= fun a -> unit (a, f))
792 module T(Wrapped : Monad.S) = struct
793 module BaseT = struct
794 module Wrapped = Wrapped
795 type ('x,'a) m = ('x,'a * log) Wrapped.m
796 type ('x,'a) result = ('x,'a * log) Wrapped.result
797 type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
799 Wrapped.bind w (fun a -> Wrapped.unit (a, Log.zero))
801 Wrapped.bind u (fun (a, w) ->
802 Wrapped.bind (f a) (fun (b, w') ->
803 Wrapped.unit (b, Log.plus w w')))
804 let zero () = elevate (Wrapped.zero ())
805 let plus u v = Wrapped.plus u v
806 let run u = Wrapped.run u
807 let run_exn u = Wrapped.run_exn u
809 include Monad.MakeT(BaseT)
810 let tell entries = Wrapped.unit ((), entries)
811 let listen u = Wrapped.bind u (fun (a, w) -> Wrapped.unit ((a, w), w))
812 let pass u = Wrapped.bind u (fun ((a, f), w) -> Wrapped.unit (a, f w))
813 (* rest are derived in same way as before *)
814 let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w)
815 let censor f u = pass (u >>= fun a -> unit (a, f))
819 (* pre-define simple Writer *)
820 module Writer1 = Writer_monad(struct
823 let plus s1 s2 = s1 ^ "\n" ^ s2
826 (* slightly more efficient Writer *)
827 module Writer2 = struct
828 include Writer_monad(struct
829 type log = string list
831 let plus w w' = Util.append w' w
833 let tell_string s = tell [s]
834 let tell entries = tell (Util.reverse entries)
835 let run u = let (a, w) = run u in (a, Util.reverse w)
841 module IO_monad : sig
842 (* declare additional operation, while still hiding implementation of type m *)
843 type ('x,'a) result = 'a
844 type ('x,'a) result_exn = 'a
845 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
846 val printf : ('a, unit, string, ('x,unit) m) format4 -> 'a
847 val print_string : string -> ('x,unit) m
848 val print_int : int -> ('x,unit) m
849 val print_hex : int -> ('x,unit) m
850 val print_bool : bool -> ('x,unit) m
853 type ('x,'a) m = { run : unit -> unit; value : 'a }
854 type ('x,'a) result = 'a
855 type ('x,'a) result_exn = 'a
856 let unit a = { run = (fun () -> ()); value = a }
857 let bind (a : ('x,'a) m) (f: 'a -> ('x,'b) m) : ('x,'b) m =
858 let fres = f a.value in
859 { run = (fun () -> a.run (); fres.run ()); value = fres.value }
860 let run a = let () = a.run () in a.value
862 let zero () = Util.undef
865 include Monad.Make(Base)
867 Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
868 let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
869 let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
870 let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
871 let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
875 module Continuation_monad : sig
876 (* expose only the implementation of type `('r,'a) result` *)
878 type ('r,'a) result = ('r,'a) m
879 type ('r,'a) result_exn = ('a -> 'r) -> 'r
880 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
881 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
882 val reset : ('a,'a) m -> ('r,'a) m
883 val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
884 (* val abort : ('a,'a) m -> ('a,'b) m *)
885 val abort : 'a -> ('a,'b) m
886 val run0 : ('a,'a) m -> 'a
887 (* ContinuationT transformer *)
888 module T : functor (Wrapped : Monad.S) -> sig
890 type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
891 type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
892 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
893 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
894 val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
895 (* TODO: reset,shift,abort,run0 *)
900 (* 'r is result type of whole computation *)
901 type ('r,'a) m = ('a -> 'r) -> 'r
902 type ('r,'a) result = ('a -> 'r) -> 'r
903 type ('r,'a) result_exn = ('r,'a) result
904 let unit a = (fun k -> k a)
905 let bind u f = (fun k -> (u) (fun a -> (f a) k))
908 let zero () = Util.undef
911 include Monad.Make(Base)
912 let callcc f = (fun k ->
913 let usek a = (fun _ -> k a)
916 val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
917 val throw : ('a -> 'r) -> 'a -> ('r,'b) m
918 let callcc f = fun k -> f k k
919 let throw k a = fun _ -> k a
922 (* from http://www.haskell.org/haskellwiki/MonadCont_done_right
924 * reset :: (Monad m) => ContT a m a -> ContT r m a
925 * reset e = ContT $ \k -> runContT e return >>= k
927 * shift :: (Monad m) => ((a -> ContT r m b) -> ContT b m b) -> ContT b m a
928 * shift e = ContT $ \k ->
929 * runContT (e $ \v -> ContT $ \c -> k v >>= c) return *)
930 let reset u = unit ((u) id)
931 let shift f = (fun k -> (f (fun a -> unit (k a))) id)
932 (* let abort a = shift (fun _ -> a) *)
933 let abort a = shift (fun _ -> unit a)
934 let run0 (u : ('a,'a) m) = (u) id
935 module T(Wrapped : Monad.S) = struct
936 module BaseT = struct
937 module Wrapped = Wrapped
938 type ('r,'a) m = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.m
939 type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
940 type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
941 let elevate w = fun k -> Wrapped.bind w k
942 let bind u f = fun k -> u (fun a -> f a k)
943 let run u k = Wrapped.run (u k)
944 let run_exn u k = Wrapped.run_exn (u k)
945 let zero () = Util.undef
948 include Monad.MakeT(BaseT)
949 let callcc f = (fun k ->
950 let usek a = (fun _ -> k a)
958 * (define (example n)
959 * (let ([u (let/cc k ; type int -> int pair
960 * (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
961 * (+ 1 (car v))))]) ; int
962 * (cons u 0))) ; int pair
963 * ; (example 10) ~~> '(111 . 0)
964 * ; (example -10) ~~> '(0 . 0)
967 * let example n : (int * int) =
968 * Continuation_monad.(let u = callcc (fun k ->
969 * (if n < 0 then k 0 else unit [n + 100])
970 * (* all of the following is skipped by k 0; the end type int is k's input type *)
971 * >>= fun [x] -> unit (x + 1)
973 * (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
974 * >>= fun x -> unit (x, 0)
978 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
979 * let example1 () : int =
980 * Continuation_monad.(let v = reset (
981 * let u = shift (fun k -> unit (10 + 1))
982 * in u >>= fun x -> unit (100 + x)
983 * ) in let w = v >>= fun x -> unit (1000 + x)
986 * (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
988 * Continuation_monad.(let v = reset (
989 * let u = shift (fun k -> k (10 :: [1]))
990 * in u >>= fun x -> unit (100 :: x)
991 * ) in let w = v >>= fun x -> unit (1000 :: x)
994 * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
996 * Continuation_monad.(let v = reset (
997 * let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
998 * in u >>= fun x -> unit (100 :: x)
999 * ) in let w = v >>= fun x -> unit (1000 :: x)
1002 * (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1003 * (* not sure if this example can be typed without a sum-type *)
1005 * (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1006 * let example5 () : int =
1007 * Continuation_monad.(let v = reset (
1008 * let u = shift (fun k -> k 1 >>= fun x -> k x)
1009 * in u >>= fun x -> unit (10 + x)
1010 * ) in let w = v >>= fun x -> unit (100 + x)
1016 module Leaf_monad : sig
1017 (* We implement the type as `'a tree option` because it has a natural`plus`,
1018 * and the rest of the library expects that `plus` and `zero` will come together. *)
1019 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1020 type ('x,'a) result = 'a tree option
1021 type ('x,'a) result_exn = 'a tree
1022 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1023 (* LeafT transformer *)
1024 module T : functor (Wrapped : Monad.S) -> sig
1025 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1026 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1027 include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1028 val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
1029 (* note that second argument is an 'a tree?, not the more abstract 'a m *)
1030 (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
1031 val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
1034 type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1035 (* uses supplied plus and zero to copy t to its image under f *)
1036 let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
1038 | Some ts -> let rec loop ts = (match ts with
1041 (* recursive application of f may delete a branch *)
1042 plus (loop l) (loop r)
1044 module Base = struct
1045 type ('x,'a) m = 'a tree option
1046 type ('x,'a) result = 'a tree option
1047 type ('x,'a) result_exn = 'a tree
1048 let unit a = Some (Leaf a)
1050 (* satisfies Distrib *)
1051 let plus u v = match (u, v) with
1054 | Some us, Some vs -> Some (Node (us, vs))
1055 let bind u f = mapT f u zero plus
1057 let run_exn u = match u with
1058 | None -> failwith "no values"
1060 | Some (Leaf a) -> a
1061 | many -> failwith "multiple values"
1065 include Monad.Make(Base)
1066 module T(Wrapped : Monad.S) = struct
1067 module BaseT = struct
1068 include Monad.MakeT(struct
1069 module Wrapped = Wrapped
1070 type ('x,'a) m = ('x,'a tree option) Wrapped.m
1071 type ('x,'a) result = ('x,'a tree option) Wrapped.result
1072 type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1073 let zero () = Wrapped.unit None
1075 Wrapped.bind u (fun us ->
1076 Wrapped.bind v (fun vs ->
1077 Wrapped.unit (Base.plus us vs)))
1078 let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1079 let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1080 let run u = Wrapped.run u
1082 let w = Wrapped.bind u (fun t -> match t with
1083 | None -> Wrapped.zero ()
1084 | Some ts -> Wrapped.unit ts
1085 ) in Wrapped.run_exn w
1089 let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1094 module L = List_monad;;
1095 module R = Reader_monad(struct type env = int -> int end);;
1096 module S = State_monad(struct type store = int end);;
1097 module T = Leaf_monad;;
1098 module LR = L.T(R);;
1099 module LS = L.T(S);;
1100 module TL = T.T(L);;
1101 module TR = T.T(R);;
1102 module TS = T.T(S);;
1103 module C = Continuation_monad
1104 module TC = T.T(C);;
1107 print_endline "=== test Leaf(...).distribute ==================";;
1109 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))));;
1111 let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
1114 - : int T.tree option * S.store =
1117 (T.Node (T.Leaf 2, T.Leaf 3),
1118 T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
1122 let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
1125 - : (int * S.store) T.tree option * S.store =
1128 (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
1129 T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
1133 let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
1134 TR.run_exn tr (fun i -> i+i);;
1136 - : int T.tree option =
1139 (T.Node (T.Leaf 4, T.Leaf 6),
1140 T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
1143 let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
1146 - : (int * int) TL.result =
1149 (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
1150 T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
1153 let l2 = [1;2;3;4;5];;
1154 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))));;
1156 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);;
1157 (* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
1159 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);;
1164 (T.Node (T.Leaf 10, T.Leaf 11),
1167 (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
1168 T.Node (T.Leaf 40, T.Leaf 41)),
1169 T.Node (T.Leaf 50, T.Leaf 51))))
1172 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;;
1174 - : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
1177 print_endline "=== test Leaf(Continuation).distribute ==================";;
1179 let id : 'z. 'z -> 'z = fun x -> x
1181 let example n : (int * int) =
1182 Continuation_monad.(let u = callcc (fun k ->
1183 (if n < 0 then k 0 else unit [n + 100])
1184 (* all of the following is skipped by k 0; the end type int is k's input type *)
1185 >>= fun [x] -> unit (x + 1)
1187 (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1188 >>= fun x -> unit (x, 0)
1192 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1193 let example1 () : int =
1194 Continuation_monad.(let v = reset (
1195 let u = shift (fun k -> unit (10 + 1))
1196 in u >>= fun x -> unit (100 + x)
1197 ) in let w = v >>= fun x -> unit (1000 + x)
1200 (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1202 Continuation_monad.(let v = reset (
1203 let u = shift (fun k -> k (10 :: [1]))
1204 in u >>= fun x -> unit (100 :: x)
1205 ) in let w = v >>= fun x -> unit (1000 :: x)
1208 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1210 Continuation_monad.(let v = reset (
1211 let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1212 in u >>= fun x -> unit (100 :: x)
1213 ) in let w = v >>= fun x -> unit (1000 :: x)
1216 (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1217 (* not sure if this example can be typed without a sum-type *)
1219 (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1220 let example5 () : int =
1221 Continuation_monad.(let v = reset (
1222 let u = shift (fun k -> k 1 >>= k)
1223 in u >>= fun x -> unit (10 + x)
1224 ) in let w = v >>= fun x -> unit (100 + x)
1229 print_endline "=== test bare Continuation ============";;
1231 (1011, 1111, 1111, 121);;
1232 (example1(), example2(), example3(), example5());;
1234 (example ~+10, example ~-10);;
1237 C.run_exn TC.(run (distribute df t1)) ic;;
1242 let initial_continuation = fun t -> t in
1243 TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
1248 (* count leaves, using continuation *)
1249 let initial_continuation = fun t -> 0 in
1250 TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
1253 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
1256 (* convert tree to list of leaves *)
1257 let initial_continuation = fun t -> [] in
1258 TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
1261 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
1264 (* square each leaf using continuation *)
1265 let initial_continuation = fun t -> t in
1266 TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
1269 testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
1273 (* replace leaves with list, using continuation *)
1274 let initial_continuation = fun t -> t in
1275 TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
1278 testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;
1280 print_endline "=== pa_monad's Continuation Tests ============";;
1282 (1, 5 = C.(run0 (unit 1 >>= fun x -> unit (x+4))) );;
1283 (2, 9 = C.(run0 (reset (unit 5 >>= fun x -> unit (x+4)))) );;
1284 (3, 9 = C.(run0 (reset (abort 5 >>= fun y -> unit (y+6)) >>= fun x -> unit (x+4))) );;
1285 (4, 9 = C.(run0 (reset (reset (abort 5 >>= fun y -> unit (y+6))) >>= fun x -> unit (x+4))) );;
1287 let c = reset(abort 5 >>= fun y -> unit (y+6))
1288 in reset(c >>= fun v1 -> abort 7 >>= fun v2 -> unit (v2+10) ) >>= fun x -> unit (x+20))) );;
1290 (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))) );;
1292 (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))) );;
1294 (12, ["a"] = C.(run0 (reset (shift (fun f -> f [] >>= fun t -> unit ("a"::t) ) >>= fun xv -> shift (fun _ -> unit xv)))) );;
1297 (0, 15 = C.(run0 (let f k = k 10 >>= fun v-> unit (v+100) in reset (callcc f >>= fun v -> unit (v+5)))) );;