typo in untyped_evaluator
[lambda.git] / code / _monads.ml
1 (*
2  * monads.ml
3  *
4  * Relies on features introduced in OCaml 3.12
5  *
6  * This library uses parameterized modules, see tree_monadize.ml for
7  * more examples and explanation.
8  *
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`,
18  * you do this:
19  *     Reader { runReader = E }
20  * or use any of the following equivalent shorthands:
21  *     Reader (E)
22  *     Reader $ E
23  * To drop an expression R of type `Reader a` back into an `env -> a`, you do
24  * one of these:
25  *     runReader (R)
26  *     runReader $ R
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.
31  *
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
35  * in Haskell.
36  *
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.
44  *
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
53  *
54  * Licensing: MIT (if that's compatible with the ghc sources this is partly
55  * derived from)
56  *)
57
58
59 (* Some library functions used below. *)
60
61 exception Undefined
62
63 module Util = struct
64   let fold_right = List.fold_right
65   let map = List.map
66   let append = List.append
67   let reverse = List.rev
68   let concat = List.concat
69   let concat_map f lst = List.concat (List.map f lst)
70   (* let zip = List.combine *)
71   let unzip = List.split
72   let zip_with = List.map2
73   let replicate len fill =
74     let rec loop n accu =
75       if n == 0 then accu else loop (pred n) (fill :: accu)
76     in loop len []
77   (* Dirty hack to be a default polymorphic zero.
78    * To implement this cleanly, monads without a natural zero
79    * should always wrap themselves in an option layer (see Tree_monad). *)
80   let undef = Obj.magic (fun () -> raise Undefined)
81 end
82
83 (*
84  * This module contains factories that extend a base set of
85  * monadic definitions with a larger family of standard derived values.
86  *)
87
88 module Monad = struct
89
90   (*
91    * Signature extenders:
92    *   Make :: BASE -> S
93    *   MakeT :: BASET (with Wrapped : S) -> result sig not declared
94    *)
95
96
97   (* type of base definitions *)
98   module type BASE = sig
99     (* We make all monadic types doubly-parameterized so that they
100      * can layer nicely with Continuation, which needs the second
101      * type parameter. *)
102     type ('x,'a) m
103     type ('x,'a) result
104     type ('x,'a) result_exn
105     val unit : 'a -> ('x,'a) m
106     val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
107     val run : ('x,'a) m -> ('x,'a) result
108     (* run_exn tries to provide a more ground-level result, but may fail *)
109     val run_exn : ('x,'a) m -> ('x,'a) result_exn
110     (* To simplify the library, we require every monad to supply a plus and zero. These obey the following laws:
111      *     zero >>= f   ===  zero
112      *     plus zero u  ===  u
113      *     plus u zero  ===  u
114      * Additionally, they will obey one of the following laws:
115      *     (Catch)   plus (unit a) v  ===  unit a
116      *     (Distrib) plus u v >>= f   ===  plus (u >>= f) (v >>= f)
117      * When no natural zero is available, use `let zero () = Util.undef`.
118      * The Make functor automatically detects for zero >>= ..., and
119      * plus zero _, plus _ zero; it also substitutes zero for pattern-match failures.
120      *)
121     val zero : unit -> ('x,'a) m
122     (* zero has to be thunked to ensure results are always poly enough *)
123     val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
124   end
125   module type S = sig
126     include BASE
127     val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
128     val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
129     val join : ('x,('x,'a) m) m -> ('x,'a) m
130     val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
131     val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
132     val lift2 :  ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
133     val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
134     val do_when :  bool -> ('x,unit) m -> ('x,unit) m
135     val do_unless :  bool -> ('x,unit) m -> ('x,unit) m
136     val forever : (unit -> ('x,'a) m) -> ('x,'b) m
137     val sequence : ('x,'a) m list -> ('x,'a list) m
138     val sequence_ : ('x,'a) m list -> ('x,unit) m
139     val guard : bool -> ('x,unit) m
140     val sum : ('x,'a) m list -> ('x,'a) m
141   end
142
143   module Make(B : BASE) : S with type ('x,'a) m = ('x,'a) B.m and type ('x,'a) result = ('x,'a) B.result and type ('x,'a) result_exn = ('x,'a) B.result_exn = struct
144     include B
145     let bind (u : ('x,'a) m) (f : 'a -> ('x,'b) m) : ('x,'b) m =
146       if u == Util.undef then Util.undef
147       else B.bind u (fun a -> try f a with Match_failure _ -> zero ())
148     let plus u v =
149       if u == Util.undef then v else if v == Util.undef then u else B.plus u v
150     let run u =
151       if u == Util.undef then raise Undefined else B.run u
152     let run_exn u =
153       if u == Util.undef then raise Undefined else B.run_exn u
154     let (>>=) = bind
155     (* expressions after >> will be evaluated before they're passed to
156      * bind, so you can't do `zero () >> assert false`
157      * this works though: `zero () >>= fun _ -> assert false`
158      *)
159     let (>>) u v = u >>= fun _ -> v
160     let lift f u = u >>= fun a -> unit (f a)
161     (* lift is called listM, fmap, and <$> in Haskell *)
162     let join uu = uu >>= fun u -> u
163     (* u >>= f === join (lift f u) *)
164     let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
165     (* [f] <*> [x1,x2] = [f x1,f x2] *)
166     (* let apply u v = u >>= fun f -> lift f v *)
167     (* let apply = lift2 id *)
168     let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
169     (* let lift f u === apply (unit f) u *)
170     (* let lift2 f u v = apply (lift f u) v *)
171     let (>=>) f g = fun a -> f a >>= g
172     let do_when test u = if test then u else unit ()
173     let do_unless test u = if test then unit () else u
174     (* A Haskell-like version works:
175          let rec forever uthunk = uthunk () >>= fun _ -> forever uthunk
176      * but the recursive call is not in tail position so this can stack overflow. *)
177     let forever uthunk =
178         let z = zero () in
179         let id result = result in
180         let kcell = ref id in
181         let rec loop _ =
182             let result = uthunk (kcell := id) >>= chained
183             in !kcell result
184         and chained _ =
185             kcell := loop; z (* we use z only for its polymorphism *)
186         in loop z
187     (* Reimplementations of the preceding using a hand-rolled State or StateT
188 can also stack overflow. *)
189     let sequence ms =
190       let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
191         Util.fold_right op ms (unit [])
192     let sequence_ ms =
193       Util.fold_right (>>) ms (unit ())
194
195     (* Haskell defines these other operations combining lists and monads.
196      * We don't, but notice that M.mapM == ListT(M).distribute
197      * There's also a parallel TreeT(M).distribute *)
198     (*
199     let mapM f alist = sequence (Util.map f alist)
200     let mapM_ f alist = sequence_ (Util.map f alist)
201     let rec filterM f lst = match lst with
202       | [] -> unit []
203       | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
204     let forM alist f = mapM f alist
205     let forM_ alist f = mapM_ f alist
206     let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
207     let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
208     let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
209     let rec foldM f z lst = match lst with
210       | [] -> unit z
211       | x::xs -> f z x >>= fun z' -> foldM f z' xs
212     let foldM_ f z xs = foldM f z xs >> unit ()
213     let replicateM n x = sequence (Util.replicate n x)
214     let replicateM_ n x = sequence_ (Util.replicate n x)
215     *)
216     let guard test = if test then B.unit () else zero ()
217     let sum ms = Util.fold_right plus ms (zero ())
218   end
219
220   (* Signatures for MonadT *)
221   module type BASET = sig
222     module Wrapped : S
223     type ('x,'a) m
224     type ('x,'a) result
225     type ('x,'a) result_exn
226     val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
227     val run : ('x,'a) m -> ('x,'a) result
228     val run_exn : ('x,'a) m -> ('x,'a) result_exn
229     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
230     (* lift/elevate laws:
231      *     elevate (W.unit a) == unit a
232      *     elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
233      *)
234     val zero : unit -> ('x,'a) m
235     val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
236   end
237   module MakeT(T : BASET) = struct
238     include Make(struct
239         include T
240         let unit a = elevate (Wrapped.unit a)
241     end)
242     let elevate = T.elevate
243   end
244
245 end
246
247
248
249
250
251 module Identity_monad : sig
252   (* expose only the implementation of type `'a result` *)
253   type ('x,'a) result = 'a
254   type ('x,'a) result_exn = 'a
255   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
256 end = struct
257   module Base = struct
258     type ('x,'a) m = 'a
259     type ('x,'a) result = 'a
260     type ('x,'a) result_exn = 'a
261     let unit a = a
262     let bind a f = f a
263     let run a = a
264     let run_exn a = a
265     let zero () = Util.undef
266     let plus u v = u
267   end
268   include Monad.Make(Base)
269 end
270
271
272 module Maybe_monad : sig
273   (* expose only the implementation of type `'a result` *)
274   type ('x,'a) result = 'a option
275   type ('x,'a) result_exn = 'a
276   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
277   (* MaybeT transformer *)
278   module T : functor (Wrapped : Monad.S) -> sig
279     type ('x,'a) result = ('x,'a option) Wrapped.result
280     type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
281     include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
282     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
283   end
284 end = struct
285   module Base = struct
286     type ('x,'a) m = 'a option
287     type ('x,'a) result = 'a option
288     type ('x,'a) result_exn = 'a
289     let unit a = Some a
290     let bind u f = match u with Some a -> f a | None -> None
291     let run u = u
292     let run_exn u = match u with
293       | Some a -> a
294       | None -> failwith "no value"
295     let zero () = None
296     (* satisfies Catch *)
297     let plus u v = match u with None -> v | _ -> u
298   end
299   include Monad.Make(Base)
300   module T(Wrapped : Monad.S) = struct
301     module BaseT = struct
302       include Monad.MakeT(struct
303         module Wrapped = Wrapped
304         type ('x,'a) m = ('x,'a option) Wrapped.m
305         type ('x,'a) result = ('x,'a option) Wrapped.result
306         type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
307         let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
308         let bind u f = Wrapped.bind u (fun t -> match t with
309           | Some a -> f a
310           | None -> Wrapped.unit None)
311         let run u = Wrapped.run u
312         let run_exn u =
313           let w = Wrapped.bind u (fun t -> match t with
314             | Some a -> Wrapped.unit a
315             | None -> Wrapped.zero ()
316           ) in Wrapped.run_exn w
317         let zero () = Wrapped.unit None
318         let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
319       end)
320     end
321     include BaseT
322   end
323 end
324
325
326 module List_monad : sig
327   (* declare additional operation, while still hiding implementation of type m *)
328   type ('x,'a) result = 'a list
329   type ('x,'a) result_exn = 'a
330   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
331   val permute : ('x,'a) m -> ('x,('x,'a) m) m
332   val select : ('x,'a) m -> ('x,'a * ('x,'a) m) m
333   (* ListT transformer *)
334   module T : functor (Wrapped : Monad.S) -> sig
335     type ('x,'a) result = ('x,'a list) Wrapped.result
336     type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
337     include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
338     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
339     (* note that second argument is an 'a list, not the more abstract 'a m *)
340     (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
341     val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
342     val permute : ('x,'a) m -> ('x,('x,'a) m) m
343     val select : ('x,'a) m -> ('x,('a * ('x,'a) m)) m
344     val expose : ('x,'a) m -> ('x,'a list) Wrapped.m
345   end
346 end = struct
347   module Base = struct
348    type ('x,'a) m = 'a list
349    type ('x,'a) result = 'a list
350    type ('x,'a) result_exn = 'a
351    let unit a = [a]
352    let bind u f = Util.concat_map f u
353    let run u = u
354    let run_exn u = match u with
355      | [] -> failwith "no values"
356      | [a] -> a
357      | many -> failwith "multiple values"
358    let zero () = []
359    (* satisfies Distrib *)
360    let plus = Util.append
361   end
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]] *)
365   let rec insert a u =
366     plus (unit (a :: u)) (match u with
367         | [] -> zero ()
368         | x :: xs -> (insert a xs) >>= fun v -> unit (x :: v)
369     )
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
372       | [] -> unit []
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
376     | [] -> zero ()
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  ===
380          let plus1 u v =
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)
387
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])
394       let bind u f =
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
399       let run_exn 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 []
406       let plus u v =
407         Wrapped.bind u (fun us ->
408         Wrapped.bind v (fun vs ->
409         Wrapped.unit (Base.plus us vs)))
410     end)
411
412    (* insert 3 {[1;2]} ~~> {[ {[3;1;2]}; {[1;3;2]}; {[1;2;3]} ]} *)
413    let rec insert a u =
414      plus
415      (unit (Wrapped.bind u (fun us -> Wrapped.unit (a :: us))))
416      (Wrapped.bind u (fun us -> match us with
417          | [] -> zero ()
418          | x::xs -> (insert a (Wrapped.unit xs)) >>= fun v -> unit (Wrapped.bind v (fun vs -> Wrapped.unit (x :: vs)))))
419
420    (* select {[1;2;3]} ~~> {[ (1,{[2;3]}); (2,{[1;3]}), (3;{[1;2]}) ]} *)
421    let rec select u =
422      Wrapped.bind u (fun us -> match us with
423          | [] -> zero ()
424          | x::xs -> plus (unit (x, Wrapped.unit xs))
425              (select (Wrapped.unit xs) >>= fun (x', xs') -> unit (x', Wrapped.bind xs' (fun ys -> Wrapped.unit (x :: ys)))))
426
427    (* permute {[1;2;3]} ~~> {[ {[1;2;3]}; {[2;1;3]}; {[2;3;1]}; {[1;3;2]}; {[3;1;2]}; {[3;2;1]} ]} *)
428
429    let rec permute u =
430      Wrapped.bind u (fun us -> match us with
431          | [] -> unit (zero ())
432          | x::xs -> permute (Wrapped.unit xs) >>= (fun v -> insert x v))
433
434     let expose u = u
435   end
436 end
437
438
439 (* must be parameterized on (struct type err = ... end) *)
440 module Error_monad(Err : sig
441   type err
442   exception Exc of err
443   (*
444   val zero : unit -> err
445   val plus : err -> err -> err
446   *)
447 end) : sig
448   (* declare additional operations, while still hiding implementation of type m *)
449   type err = Err.err
450   type 'a error = Error of err | Success of 'a
451   type ('x,'a) result = 'a error
452   type ('x,'a) result_exn = 'a
453   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
454   val throw : err -> ('x,'a) m
455   val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
456   (* ErrorT transformer *)
457   module T : functor (Wrapped : Monad.S) -> sig
458     type ('x,'a) result = ('x,'a) Wrapped.result
459     type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
460     include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
461     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
462     val throw : err -> ('x,'a) m
463     val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
464   end
465 end = struct
466   type err = Err.err
467   type 'a error = Error of err | Success of 'a
468   module Base = struct
469     type ('x,'a) m = 'a error
470     type ('x,'a) result = 'a error
471     type ('x,'a) result_exn = 'a
472     let unit a = Success a
473     let bind u f = match u with
474       | Success a -> f a
475       | Error e -> Error e (* input and output may be of different 'a types *)
476     let run u = u
477     let run_exn u = match u with
478       | Success a -> a
479       | Error e -> raise (Err.Exc e)
480     let zero () = Util.undef
481     (* satisfies Catch *)
482     let plus u v = match u with
483       | Success _ -> u
484       | Error _ -> if v == Util.undef then u else v
485   end
486   include Monad.Make(Base)
487   (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
488   let throw e = Error e
489   let catch u handler = match u with
490     | Success _ -> u
491     | Error e -> handler e
492   module T(Wrapped : Monad.S) = struct
493     include Monad.MakeT(struct
494       module Wrapped = Wrapped
495       type ('x,'a) m = ('x,'a error) Wrapped.m
496       type ('x,'a) result = ('x,'a) Wrapped.result
497       type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
498       let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
499       let bind u f = Wrapped.bind u (fun t -> match t with
500         | Success a -> f a
501         | Error e -> Wrapped.unit (Error e))
502       let run u =
503         let w = Wrapped.bind u (fun t -> match t with
504           | Success a -> Wrapped.unit a
505           | Error e -> Wrapped.zero ()
506         ) in Wrapped.run w
507       let run_exn u =
508         let w = Wrapped.bind u (fun t -> match t with
509           | Success a -> Wrapped.unit a
510           | Error e -> raise (Err.Exc e))
511         in Wrapped.run_exn w
512       let plus u v = Wrapped.plus u v
513       let zero () = Wrapped.zero () (* elevate (Wrapped.zero ()) *)
514     end)
515     let throw e = Wrapped.unit (Error e)
516     let catch u handler = Wrapped.bind u (fun t -> match t with
517       | Success _ -> Wrapped.unit t
518       | Error e -> handler e)
519   end
520 end
521
522 (* pre-define common instance of Error_monad *)
523 module Failure = Error_monad(struct
524   type err = string
525   exception Exc = Failure
526   (*
527   let zero = ""
528   let plus s1 s2 = s1 ^ "\n" ^ s2
529   *)
530 end)
531
532
533 (* must be parameterized on (struct type env = ... end) *)
534 module Reader_monad(Env : sig type env end) : sig
535   (* declare additional operations, while still hiding implementation of type m *)
536   type env = Env.env
537   type ('x,'a) result = env -> 'a
538   type ('x,'a) result_exn = env -> 'a
539   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
540   val ask : ('x,env) m
541   val asks : (env -> 'a) -> ('x,'a) m
542   (* lookup i == `fun e -> e i` would assume env is a functional type *)
543   val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
544   (* ReaderT transformer *)
545   module T : functor (Wrapped : Monad.S) -> sig
546     type ('x,'a) result = env -> ('x,'a) Wrapped.result
547     type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
548     include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
549     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
550     val ask : ('x,env) m
551     val asks : (env -> 'a) -> ('x,'a) m
552     val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
553     val expose : ('x,'a) m -> env -> ('x,'a) Wrapped.m
554   end
555 end = struct
556   type env = Env.env
557   module Base = struct
558     type ('x,'a) m = env -> 'a
559     type ('x,'a) result = env -> 'a
560     type ('x,'a) result_exn = env -> 'a
561     let unit a = fun e -> a
562     let bind u f = fun e -> let a = u e in let u' = f a in u' e
563     let run u = fun e -> u e
564     let run_exn = run
565     let zero () = Util.undef
566     let plus u v = u
567   end
568   include Monad.Make(Base)
569   let ask = fun e -> e
570   let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
571   let local modifier u = fun e -> u (modifier e)
572   module T(Wrapped : Monad.S) = struct
573     module BaseT = struct
574       module Wrapped = Wrapped
575       type ('x,'a) m = env -> ('x,'a) Wrapped.m
576       type ('x,'a) result = env -> ('x,'a) Wrapped.result
577       type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
578       let elevate w = fun e -> w
579       let bind u f = fun e -> Wrapped.bind (u e) (fun a -> f a e)
580       let run u = fun e -> Wrapped.run (u e)
581       let run_exn u = fun e -> Wrapped.run_exn (u e)
582       (* satisfies Distrib *)
583       let plus u v = fun e -> Wrapped.plus (u e) (v e)
584       let zero () = fun e -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
585     end
586     include Monad.MakeT(BaseT)
587     let ask = Wrapped.unit
588     let local modifier u = fun e -> u (modifier e)
589     let asks selector = ask >>= (fun e ->
590       try unit (selector e)
591       with Not_found -> fun e -> Wrapped.zero ())
592     let expose u = u
593   end
594 end
595
596
597 (* must be parameterized on (struct type store = ... end) *)
598 module State_monad(Store : sig type store end) : sig
599   (* declare additional operations, while still hiding implementation of type m *)
600   type store = Store.store
601   type ('x,'a) result =  store -> 'a * store
602   type ('x,'a) result_exn = store -> 'a
603   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
604   val get : ('x,store) m
605   val gets : (store -> 'a) -> ('x,'a) m
606   val put : store -> ('x,unit) m
607   val puts : (store -> store) -> ('x,unit) m
608   (* StateT transformer *)
609   module T : functor (Wrapped : Monad.S) -> sig
610     type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
611     type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
612     include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
613     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
614     val get : ('x,store) m
615     val gets : (store -> 'a) -> ('x,'a) m
616     val put : store -> ('x,unit) m
617     val puts : (store -> store) -> ('x,unit) m
618     (* val passthru : ('x,'a) m -> (('x,'a * store) Wrapped.result * store -> 'b) -> ('x,'b) m *)
619     val expose : ('x,'a) m -> store -> ('x,'a * store) Wrapped.m
620   end
621 end = struct
622   type store = Store.store
623   module Base = struct
624     type ('x,'a) m =  store -> 'a * store
625     type ('x,'a) result =  store -> 'a * store
626     type ('x,'a) result_exn = store -> 'a
627     let unit a = fun s -> (a, s)
628     let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
629     let run u = fun s -> (u s)
630     let run_exn u = fun s -> fst (u s)
631     let zero () = Util.undef
632     let plus u v = u
633   end
634   include Monad.Make(Base)
635   let get = fun s -> (s, s)
636   let gets viewer = fun s -> (viewer s, s) (* may fail *)
637   let put s = fun _ -> ((), s)
638   let puts modifier = fun s -> ((), modifier s)
639   module T(Wrapped : Monad.S) = struct
640     module BaseT = struct
641       module Wrapped = Wrapped
642       type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
643       type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
644       type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
645       let elevate w = fun s ->
646         Wrapped.bind w (fun a -> Wrapped.unit (a, s))
647       let bind u f = fun s ->
648         Wrapped.bind (u s) (fun (a, s') -> f a s')
649       let run u = fun s -> Wrapped.run (u s)
650       let run_exn u = fun s ->
651         let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
652         in Wrapped.run_exn w
653       (* satisfies Distrib *)
654       let plus u v = fun s -> Wrapped.plus (u s) (v s)
655       let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
656     end
657     include Monad.MakeT(BaseT)
658     let get = fun s -> Wrapped.unit (s, s)
659     let gets viewer = fun s ->
660       try Wrapped.unit (viewer s, s)
661       with Not_found -> Wrapped.zero ()
662     let put s = fun _ -> Wrapped.unit ((), s)
663     let puts modifier = fun s -> Wrapped.unit ((), modifier s)
664     (* let passthru u f = fun s -> Wrapped.unit (f (Wrapped.run (u s), s), s) *)
665     let expose u = u
666   end
667 end
668
669
670 (* State monad with different interface (structured store) *)
671 module Ref_monad(V : sig
672   type value
673 end) : sig
674   type ref
675   type value = V.value
676   type ('x,'a) result = 'a
677   type ('x,'a) result_exn = 'a
678   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
679   val newref : value -> ('x,ref) m
680   val deref : ref -> ('x,value) m
681   val change : ref -> value -> ('x,unit) m
682   (* RefT transformer *)
683   module T : functor (Wrapped : Monad.S) -> sig
684     type ('x,'a) result = ('x,'a) Wrapped.result
685     type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
686     include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
687     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
688     val newref : value -> ('x,ref) m
689     val deref : ref -> ('x,value) m
690     val change : ref -> value -> ('x,unit) m
691   end
692 end = struct
693   type ref = int
694   type value = V.value
695   module D = Map.Make(struct type t = ref let compare = compare end)
696   type dict = { next: ref; tree : value D.t }
697   let empty = { next = 0; tree = D.empty }
698   let alloc (value : value) (d : dict) =
699     (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
700   let read (key : ref) (d : dict) =
701     D.find key d.tree
702   let write (key : ref) (value : value) (d : dict) =
703     { next = d.next; tree = D.add key value d.tree }
704   module Base = struct
705     type ('x,'a) m = dict -> 'a * dict
706     type ('x,'a) result = 'a
707     type ('x,'a) result_exn = 'a
708     let unit a = fun s -> (a, s)
709     let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
710     let run u = fst (u empty)
711     let run_exn = run
712     let zero () = Util.undef
713     let plus u v = u
714   end
715   include Monad.Make(Base)
716   let newref value = fun s -> alloc value s
717   let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
718   let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
719   module T(Wrapped : Monad.S) = struct
720     module BaseT = struct
721       module Wrapped = Wrapped
722       type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
723       type ('x,'a) result = ('x,'a) Wrapped.result
724       type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
725       let elevate w = fun s ->
726         Wrapped.bind w (fun a -> Wrapped.unit (a, s))
727       let bind u f = fun s ->
728         Wrapped.bind (u s) (fun (a, s') -> f a s')
729       let run u =
730         let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
731         in Wrapped.run w
732       let run_exn u =
733         let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
734         in Wrapped.run_exn w
735       (* satisfies Distrib *)
736       let plus u v = fun s -> Wrapped.plus (u s) (v s)
737       let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
738     end
739     include Monad.MakeT(BaseT)
740     let newref value = fun s -> Wrapped.unit (alloc value s)
741     let deref key = fun s -> Wrapped.unit (read key s, s)
742     let change key value = fun s -> Wrapped.unit ((), write key value s)
743   end
744 end
745
746
747 (* must be parameterized on (struct type log = ... end) *)
748 module Writer_monad(Log : sig
749   type log
750   val zero : log
751   val plus : log -> log -> log
752 end) : sig
753   (* declare additional operations, while still hiding implementation of type m *)
754   type log = Log.log
755   type ('x,'a) result = 'a * log
756   type ('x,'a) result_exn = 'a * log
757   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
758   val tell : log -> ('x,unit) m
759   val listen : ('x,'a) m -> ('x,'a * log) m
760   val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
761   (* val pass : ('x,'a * (log -> log)) m -> ('x,'a) m *)
762   val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
763   (* WriterT transformer *)
764   module T : functor (Wrapped : Monad.S) -> sig
765     type ('x,'a) result = ('x,'a * log) Wrapped.result
766     type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
767     include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
768     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
769     val tell : log -> ('x,unit) m
770     val listen : ('x,'a) m -> ('x,'a * log) m
771     val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
772     val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
773   end
774 end = struct
775   type log = Log.log
776   module Base = struct
777     type ('x,'a) m = 'a * log
778     type ('x,'a) result = 'a * log
779     type ('x,'a) result_exn = 'a * log
780     let unit a = (a, Log.zero)
781     let bind (a, w) f = let (b, w') = f a in (b, Log.plus w w')
782     let run u = u
783     let run_exn = run
784     let zero () = Util.undef
785     let plus u v = u
786   end
787   include Monad.Make(Base)
788   let tell entries = ((), entries) (* add entries to log *)
789   let listen (a, w) = ((a, w), w)
790   let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
791   let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
792   let censor f u = pass (u >>= fun a -> unit (a, f))
793   module T(Wrapped : Monad.S) = struct
794     module BaseT = struct
795       module Wrapped = Wrapped
796       type ('x,'a) m = ('x,'a * log) Wrapped.m
797       type ('x,'a) result = ('x,'a * log) Wrapped.result
798       type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
799       let elevate w =
800         Wrapped.bind w (fun a -> Wrapped.unit (a, Log.zero))
801       let bind u f =
802         Wrapped.bind u (fun (a, w) ->
803         Wrapped.bind (f a) (fun (b, w') ->
804         Wrapped.unit (b, Log.plus w w')))
805       let zero () = elevate (Wrapped.zero ())
806       let plus u v = Wrapped.plus u v
807       let run u = Wrapped.run u
808       let run_exn u = Wrapped.run_exn u
809     end
810     include Monad.MakeT(BaseT)
811     let tell entries = Wrapped.unit ((), entries)
812     let listen u = Wrapped.bind u (fun (a, w) -> Wrapped.unit ((a, w), w))
813     let pass u = Wrapped.bind u (fun ((a, f), w) -> Wrapped.unit (a, f w))
814     (* rest are derived in same way as before *)
815     let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w)
816     let censor f u = pass (u >>= fun a -> unit (a, f))
817   end
818 end
819
820 (* pre-define simple Writer *)
821 module Writer1 = Writer_monad(struct
822   type log = string
823   let zero = ""
824   let plus s1 s2 = s1 ^ "\n" ^ s2
825 end)
826
827 (* slightly more efficient Writer *)
828 module Writer2 = struct
829   include Writer_monad(struct
830     type log = string list
831     let zero = []
832     let plus w w' = Util.append w' w
833   end)
834   let tell_string s = tell [s]
835   let tell entries = tell (Util.reverse entries)
836   let run u = let (a, w) = run u in (a, Util.reverse w)
837   let run_exn = run
838 end
839
840
841 (* TODO needs a T *)
842 module IO_monad : sig
843   (* declare additional operation, while still hiding implementation of type m *)
844   type ('x,'a) result = 'a
845   type ('x,'a) result_exn = 'a
846   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
847   val printf : ('a, unit, string, ('x,unit) m) format4 -> 'a
848   val print_string : string -> ('x,unit) m
849   val print_int : int -> ('x,unit) m
850   val print_hex : int -> ('x,unit) m
851   val print_bool : bool -> ('x,unit) m
852 end = struct
853   module Base = struct
854     type ('x,'a) m = { run : unit -> unit; value : 'a }
855     type ('x,'a) result = 'a
856     type ('x,'a) result_exn = 'a
857     let unit a = { run = (fun () -> ()); value = a }
858     let bind (a : ('x,'a) m) (f: 'a -> ('x,'b) m) : ('x,'b) m =
859      let fres = f a.value in
860        { run = (fun () -> a.run (); fres.run ()); value = fres.value }
861     let run a = let () = a.run () in a.value
862     let run_exn = run
863     let zero () = Util.undef
864     let plus u v = u
865   end
866   include Monad.Make(Base)
867   let printf fmt =
868     Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
869   let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
870   let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
871   let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
872   let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
873 end
874
875
876 module Continuation_monad : sig
877   (* expose only the implementation of type `('r,'a) result` *)
878   type ('r,'a) m
879   type ('r,'a) result = ('r,'a) m
880   type ('r,'a) result_exn = ('a -> 'r) -> 'r
881   include Monad.S with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn and type ('r,'a) m := ('r,'a) m
882   val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
883   val reset : ('a,'a) m -> ('r,'a) m
884   val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
885   (* val abort : ('a,'a) m -> ('a,'b) m *)
886   val abort : 'a -> ('a,'b) m
887   val run0 : ('a,'a) m -> 'a
888   (* ContinuationT transformer *)
889   module T : functor (Wrapped : Monad.S) -> sig
890     type ('r,'a) m
891     type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
892     type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
893     include Monad.S with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn and type ('r,'a) m := ('r,'a) m
894     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
895     val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
896     (* TODO: reset,shift,abort,run0 *)
897   end
898 end = struct
899   let id = fun i -> i
900   module Base = struct
901     (* 'r is result type of whole computation *)
902     type ('r,'a) m = ('a -> 'r) -> 'r
903     type ('r,'a) result = ('a -> 'r) -> 'r
904     type ('r,'a) result_exn = ('r,'a) result
905     let unit a = (fun k -> k a)
906     let bind u f = (fun k -> (u) (fun a -> (f a) k))
907     let run u k = (u) k
908     let run_exn = run
909     let zero () = Util.undef
910     let plus u v = u
911   end
912   include Monad.Make(Base)
913   let callcc f = (fun k ->
914     let usek a = (fun _ -> k a)
915     in (f usek) k)
916   (*
917   val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
918   val throw : ('a -> 'r) -> 'a -> ('r,'b) m
919   let callcc f = fun k -> f k k
920   let throw k a = fun _ -> k a
921   *)
922
923   (* from http://www.haskell.org/haskellwiki/MonadCont_done_right
924    *
925    *  reset :: (Monad m) => ContT a m a -> ContT r m a
926    *  reset e = ContT $ \k -> runContT e return >>= k
927    *
928    *  shift :: (Monad m) => ((a -> ContT r m b) -> ContT b m b) -> ContT b m a
929    *  shift e = ContT $ \k ->
930    *              runContT (e $ \v -> ContT $ \c -> k v >>= c) return *)
931   let reset u = unit ((u) id)
932   let shift f = (fun k -> (f (fun a -> unit (k a))) id)
933   (* let abort a = shift (fun _ -> a) *)
934   let abort a = shift (fun _ -> unit a)
935   let run0 (u : ('a,'a) m) = (u) id
936   module T(Wrapped : Monad.S) = struct
937     module BaseT = struct
938       module Wrapped = Wrapped
939       type ('r,'a) m = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.m
940       type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
941       type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
942       let elevate w = fun k -> Wrapped.bind w k
943       let bind u f = fun k -> u (fun a -> f a k)
944       let run u k = Wrapped.run (u k)
945       let run_exn u k = Wrapped.run_exn (u k)
946       let zero () = Util.undef
947       let plus u v = u
948     end
949     include Monad.MakeT(BaseT)
950     let callcc f = (fun k ->
951       let usek a = (fun _ -> k a)
952       in (f usek) k)
953   end
954 end
955
956
957 (*
958  * Scheme:
959  * (define (example n)
960  *    (let ([u (let/cc k ; type int -> int pair
961  *               (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
962  *                 (+ 1 (car v))))]) ; int
963  *      (cons u 0))) ; int pair
964  * ; (example 10) ~~> '(111 . 0)
965  * ; (example -10) ~~> '(0 . 0)
966  *
967  * OCaml monads:
968  * let example n : (int * int) =
969  *   Continuation_monad.(let u = callcc (fun k ->
970  *       (if n < 0 then k 0 else unit [n + 100])
971  *       (* all of the following is skipped by k 0; the end type int is k's input type *)
972  *       >>= fun [x] -> unit (x + 1)
973  *   )
974  *   (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
975  *   >>= fun x -> unit (x, 0)
976  *   in run u)
977  *
978  *)
979
980
981 module Tree_monad : sig
982   (* We implement the type as `'a tree option` because it has a natural`plus`,
983    * and the rest of the library expects that `plus` and `zero` will come together. *)
984   type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
985   type ('x,'a) result = 'a tree option
986   type ('x,'a) result_exn = 'a tree
987   include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
988   (* TreeT transformer *)
989   module T : functor (Wrapped : Monad.S) -> sig
990     type ('x,'a) result = ('x,'a tree option) Wrapped.result
991     type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
992     include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
993     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
994     (* note that second argument is an 'a tree?, not the more abstract 'a m *)
995     (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
996     val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
997     val expose : ('x,'a) m -> ('x,'a tree option) Wrapped.m
998   end
999 end = struct
1000   type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1001   (* uses supplied plus and zero to copy t to its image under f *)
1002   let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
1003       | None -> zero ()
1004       | Some ts -> let rec loop ts = (match ts with
1005                      | Leaf a -> f a
1006                      | Node (l, r) ->
1007                          (* recursive application of f may delete a branch *)
1008                          plus (loop l) (loop r)
1009                    ) in loop ts
1010   module Base = struct
1011     type ('x,'a) m = 'a tree option
1012     type ('x,'a) result = 'a tree option
1013     type ('x,'a) result_exn = 'a tree
1014     let unit a = Some (Leaf a)
1015     let zero () = None
1016     (* satisfies Distrib *)
1017     let plus u v = match (u, v) with
1018       | None, _ -> v
1019       | _, None -> u
1020       | Some us, Some vs -> Some (Node (us, vs))
1021     let bind u f = mapT f u zero plus
1022     let run u = u
1023     let run_exn u = match u with
1024       | None -> failwith "no values"
1025       (*
1026       | Some (Leaf a) -> a
1027       | many -> failwith "multiple values"
1028       *)
1029       | Some us -> us
1030   end
1031   include Monad.Make(Base)
1032   module T(Wrapped : Monad.S) = struct
1033     module BaseT = struct
1034       include Monad.MakeT(struct
1035         module Wrapped = Wrapped
1036         type ('x,'a) m = ('x,'a tree option) Wrapped.m
1037         type ('x,'a) result = ('x,'a tree option) Wrapped.result
1038         type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1039         let zero () = Wrapped.unit None
1040         let plus u v =
1041           Wrapped.bind u (fun us ->
1042           Wrapped.bind v (fun vs ->
1043           Wrapped.unit (Base.plus us vs)))
1044         let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1045         let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1046         let run u = Wrapped.run u
1047         let run_exn u =
1048             let w = Wrapped.bind u (fun t -> match t with
1049               | None -> Wrapped.zero ()
1050               | Some ts -> Wrapped.unit ts
1051             ) in Wrapped.run_exn w
1052       end)
1053     end
1054     include BaseT
1055     let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1056     let expose u = u
1057   end
1058
1059 end;;
1060
1061