1 (* This version from 1 April 2015 *)
5 module type MAPPABLE = sig
7 val map : ('a -> 'b) -> 'a t -> 'b t
8 (* mapconst is definable as map % const. For example mapconst 4 [1,2,3] == [4,4,4]. Haskell calls mapconst <$ in Data.Functor and Control.Applicative. They also use $> for flip mapconst, and Control.Monad.void for mapconst (). *)
11 module type APPLICATIVE = sig
14 val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
15 val mapply : ('a -> 'b) t -> 'a t -> 'b t
16 val (>>) : 'a t -> 'b t -> 'b t
17 val (<<) : 'a t -> 'b t -> 'a t
20 module type MONAD = sig
23 val run : 'a t -> 'a result
24 val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
25 val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t)
26 val (<=<) : ('b -> 'c t) -> ('a -> 'b t) -> ('a -> 'c t)
27 val join : 'a t t -> 'a t
28 val ignore : 'a t -> unit t
29 val seq : 'a t list -> 'a list t
30 val seq_ignore : unit t list -> unit t
31 val do_when : bool -> unit t -> unit t
32 val do_unless : bool -> unit t -> unit t
35 module type MONADT = sig
38 val hoist : 'a ut -> 'a t
41 module type ZERO = sig
43 (* mzero is a value of type α that is exemplified by Nothing for the box type Maybe α and by [] for the box type List α. It has the behavior that anything ¢ mzero == mzero == mzero ¢ anything == mzero >>= anything. In Haskell, this notion is called Control.Applicative.empty or Control.Monad.mzero. *)
45 val guard : bool -> unit t
48 module type MONADZERO = sig
50 include ZERO with type 'a t := 'a t
53 module type MONADZEROT = sig
55 include ZERO with type 'a t := 'a t
58 module type MAPPABLE2 = sig
60 val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
63 module type APPLICATIVE2 = sig
65 val mid : 'a -> ('a,'d) t
66 val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t
67 val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t
68 val (>>) : ('a,'d) t -> ('b,'d) t -> ('b,'d) t
69 val (<<) : ('a,'d) t -> ('b,'d) t -> ('a,'d) t
72 module type MONAD2 = sig
75 val run : ('a,'d) t -> ('a,'d) result
76 val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
77 val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t)
78 val (<=<) : ('b -> ('c,'d) t) -> ('a -> ('b,'d) t) -> ('a -> ('c,'d) t)
79 val join : (('a,'d) t,'d) t -> ('a,'d) t
80 val ignore : ('a,'d) t -> (unit,'d) t
81 val seq : ('a,'d) t list -> ('a list,'d) t
82 val seq_ignore : (unit,'d) t list -> (unit,'d) t
83 val do_when : bool -> (unit,'d) t -> (unit,'d) t
84 val do_unless : bool -> (unit,'d) t -> (unit,'d) t
87 module type MONAD2T = sig
90 val hoist : ('a,'d) ut -> ('a,'d) t
93 module type MONADZERO2 = sig
96 val guard : bool -> (unit,'d) t
99 module type MONADZERO2T = sig
102 val hoist : ('a,'d) ut -> ('a,'d) t
107 module type MAP2 = sig
110 val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
111 val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
112 val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
115 module type MAPPLY = sig
118 val mapply : ('a -> 'b) t -> 'a t -> 'b t
119 val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
120 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
123 module type BIND = sig
126 val run : 'a t -> 'a result
128 val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
129 val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
130 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
131 val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
134 module type COMP = sig
137 val run : 'a t -> 'a result
139 val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t)
140 val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
141 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
142 val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
145 module type JOIN = sig
148 val run : 'a t -> 'a result
150 val join : 'a t t -> 'a t
151 val map : ('a -> 'b) -> 'a t -> 'b t
152 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
153 val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
156 module type TRANS = sig
160 val run : 'a t -> 'a result
161 (* Provide hoist, >>=; LAWS: 1. hoist U.(mid x) == mid x; 2. hoist U.(uu >>= k) == hoist uu >>= fun u -> hoist (k u) *)
162 val hoist : 'a U.t -> 'a t
163 val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
166 module type TRANSUZ = sig
170 val run : 'a t -> 'a result
171 val hoist : 'a U.t -> 'a t
172 val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
175 module type TRANSZ = sig
179 val run : 'a t -> 'a result
180 val hoist : 'a U.t -> 'a t
181 val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
185 module ApplicativeFromBind(B : BIND) : APPLICATIVE with type 'a t = 'a B.t = struct
189 let map = match B.map with
191 | `Generate -> fun f xx -> xx >>= fun x -> mid (f x)
192 let map2 = match B.map2 with
193 | `Custom map2 -> map2
194 | `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y)
195 let mapply = match B.map2 with
196 | `Custom map2 -> fun eta -> map2 ident eta
197 | `Generate -> fun ff xx -> ff >>= fun f -> map f xx
198 let (>>) xx yy = xx >>= fun _ -> yy
199 let (<<) xx yy = mapply (map const xx) yy
202 module ApplicativeFromMap2(B : MAP2) : APPLICATIVE with type 'a t = 'a B.t = struct
206 let mapply = match B.mapply with
207 | `Custom mapply -> mapply
208 | `Generate -> fun eta -> map2 ident eta
209 let map = match B.map with
211 | `Generate -> fun f xx -> mapply (mid f) xx
212 let (>>) xx yy = mapply (map (const ident) xx) yy
213 let (<<) xx yy = mapply (map const xx) yy
216 module ApplicativeFromApply(B : MAPPLY) : APPLICATIVE with type 'a t = 'a B.t = struct
219 let mapply = B.mapply
220 let map = match B.map with
222 | `Generate -> fun f xx -> mapply (mid f) xx
223 let map2 = match B.map2 with
224 | `Custom map2 -> map2
225 | `Generate -> fun f xx yy -> mapply (map f xx) yy
226 let (>>) xx yy = mapply (map (const ident) xx) yy
227 let (<<) xx yy = mapply (map const xx) yy
230 module MonadFromBind(B : BIND) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
232 include ApplicativeFromBind(B)
233 type 'a result = 'a B.result
235 let (>=>) j k = fun a -> j a >>= k
236 let (<=<) k j = fun a -> j a >>= k
237 let join xxx = xxx >>= ident
238 let ignore xx = map (fun _ -> ()) xx
239 (* seq xxs = let f xx zzf = (xx >>=) . flip ((zzf.).(:)) in foldr f (return $) xxs [] *)
241 foldr' f z xs = foldl (\g x z -> g (f x z)) id xs z -- foldr but evaluating from left?
242 foldl'' f z xs = foldr (\x g z -> g (f z x)) id xs z -- foldl but evaluating from right? these don't work
243 -- with foldr, evaluates left->right; with foldl the reverse
245 let f c xx ret xs = xx >>= ret . c xs in -- careful! isn't fmap (c xs) xx because ret isn't (always) return
246 reverse <$> foldr (f $ flip (:)) return xxs []
247 -- or simply: foldr (f snoc) return xxs []
250 let rec aux xs = function
251 | [] -> mid (List.rev xs)
252 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
253 fun xxs -> aux [] xxs
254 let rec seq_ignore = function
256 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
257 let do_when res xx = if res then xx else mid ()
258 let do_unless res xx = if res then mid () else xx
261 module MonadFromComp(B : COMP) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
263 let (<=<) k j = j >=> k
264 let (>>=) xx k = (ident >=> k) xx
265 include ApplicativeFromBind(struct include B let (>>=) = (>>=) end)
266 type 'a result = 'a B.result
268 let join xxx = xxx >>= ident
269 let ignore xx = map (fun _ -> ()) xx
271 let rec aux xs = function
272 | [] -> mid (List.rev xs)
273 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
274 fun xxs -> aux [] xxs
275 let rec seq_ignore = function
277 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
278 let do_when res xx = if res then xx else mid ()
279 let do_unless res xx = if res then mid () else xx
282 module MonadFromJoin(B : JOIN) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
284 let (>>=) xx k = join (B.map k xx)
285 include ApplicativeFromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end)
286 type 'a result = 'a B.result
288 let (>=>) j k = fun a -> j a >>= k
289 let (<=<) k j = fun a -> j a >>= k
290 let ignore xx = map (fun _ -> ()) xx
292 let rec aux xs = function
293 | [] -> mid (List.rev xs)
294 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
295 fun xxs -> aux [] xxs
296 let rec seq_ignore = function
298 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
299 let do_when res xx = if res then xx else mid ()
300 let do_unless res xx = if res then mid () else xx
303 module MonadFromT(B : TRANS) : MONADT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct
304 include MonadFromBind(struct
306 let mid x = hoist U.(mid x)
307 let map = `Generate let map2 = `Generate let mapply = `Generate
312 module MonadFromTUZ(B : TRANSUZ) : MONADZEROT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct
313 let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
314 include MonadFromBind(struct
316 let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
317 let mid x = hoist U.(mid x)
318 let map = `Generate let map2 = `Generate let mapply = `Generate
321 let guard res = if res then mid () else mzero
324 module MonadFromTZ(B : TRANSZ) : MONADZEROT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct
325 include MonadFromBind(struct
327 let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
328 let mid x = hoist U.(mid x)
329 let map = `Generate let map2 = `Generate let mapply = `Generate
333 let guard res = if res then mid () else mzero
336 module type BIND2 = sig
339 val run : ('a,'d) t -> ('a,'d) result
340 val mid : 'a -> ('a,'d) t
341 val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
342 val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
343 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
344 val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
347 module type COMP2 = sig
350 val run : ('a,'d) t -> ('a,'d) result
351 val mid : 'a -> ('a,'d) t
352 val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t)
353 val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
354 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
355 val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
358 module type JOIN2 = sig
361 val run : ('a,'d) t -> ('a,'d) result
362 val mid : 'a -> ('a,'d) t
363 val join : (('a,'d) t,'d) t -> ('a,'d) t
364 val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
365 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
366 val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
369 module type TRANS2 = sig
373 val run : ('a,'d) t -> ('a,'d) result
374 val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
375 val hoist : ('a,'d) U.t -> ('a,'d) t
378 module type TRANSUZ2 = sig
379 module U : MONADZERO2
382 val run : ('a,'d) t -> ('a,'d) result
383 val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
384 val hoist : ('a,'d) U.t -> ('a,'d) t
387 module type TRANSZ2 = sig
391 val run : ('a,'d) t -> ('a,'d) result
392 val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
393 val hoist : ('a,'d) U.t -> ('a,'d) t
394 val mzero : ('a,'d) t
397 module type MAP22 = sig
399 val mid : 'a -> ('a,'d) t
400 val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t
401 val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
402 val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
405 module type MAPPLY2 = sig
407 val mid : 'a -> ('a,'d) t
408 val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t
409 val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
410 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
413 module Applicative2FromBind(B : BIND2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
414 type ('a,'d) t = ('a,'d) B.t
417 let map = match B.map with
419 | `Generate -> fun f xx -> xx >>= fun x -> mid (f x)
420 let map2 = match B.map2 with
421 | `Custom map2 -> map2
422 | `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y)
423 let mapply = match B.map2 with
424 | `Custom map2 -> fun eta -> map2 ident eta
425 | `Generate -> fun ff xx -> ff >>= fun f -> map f xx
426 let (>>) xx yy = xx >>= fun _ -> yy
427 let (<<) xx yy = mapply (map const xx) yy
430 module Applicative2FromMap2(B : MAP22) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
431 type ('a,'d) t = ('a,'d) B.t
434 let mapply = match B.mapply with
435 | `Custom mapply -> mapply
436 | `Generate -> fun eta -> map2 ident eta
437 let map = match B.map with
439 | `Generate -> fun f xx -> mapply (mid f) xx
440 let (>>) xx yy = mapply (map (const ident) xx) yy
441 let (<<) xx yy = mapply (map const xx) yy
444 module Applicative2FromApply(B : MAPPLY2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
445 type ('a,'d) t = ('a,'d) B.t
447 let mapply = B.mapply
448 let map = match B.map with
450 | `Generate -> fun f xx -> mapply (mid f) xx
451 let map2 = match B.map2 with
452 | `Custom map2 -> map2
453 | `Generate -> fun f xx yy -> mapply (map f xx) yy
454 let (>>) xx yy = mapply (map (const ident) xx) yy
455 let (<<) xx yy = mapply (map const xx) yy
458 module Monad2FromBind(B : BIND2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
460 include Applicative2FromBind(B)
461 type ('a,'d) result = ('a,'d) B.result
463 let (>=>) j k = fun a -> j a >>= k
464 let (<=<) k j = fun a -> j a >>= k
465 let join xxx = xxx >>= ident
466 let ignore xx = map (fun _ -> ()) xx
468 let rec aux xs = function
469 | [] -> mid (List.rev xs)
470 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
471 fun xxs -> aux [] xxs
472 let rec seq_ignore = function
474 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
475 let do_when res xx = if res then xx else mid ()
476 let do_unless res xx = if res then mid () else xx
479 module Monad2FromComp(B : COMP2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
481 let (<=<) k j = j >=> k
482 let (>>=) xx k = (ident >=> k) xx
483 include Applicative2FromBind(struct include B let (>>=) = (>>=) end)
484 type ('a,'d) result = ('a,'d) B.result
486 let join xxx = xxx >>= ident
487 let ignore xx = map (fun _ -> ()) xx
489 let rec aux xs = function
490 | [] -> mid (List.rev xs)
491 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
492 fun xxs -> aux [] xxs
493 let rec seq_ignore = function
495 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
496 let do_when res xx = if res then xx else mid ()
497 let do_unless res xx = if res then mid () else xx
500 module Monad2FromJoin(B : JOIN2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
502 let (>>=) xx k = join (B.map k xx)
503 include Applicative2FromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end)
504 type ('a,'d) result = ('a,'d) B.result
506 let (>=>) j k = fun a -> j a >>= k
507 let (<=<) k j = fun a -> j a >>= k
508 let ignore xx = map (fun _ -> ()) xx
510 let rec aux xs = function
511 | [] -> mid (List.rev xs)
512 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
513 fun xxs -> aux [] xxs
514 let rec seq_ignore = function
516 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
517 let do_when res xx = if res then xx else mid ()
518 let do_unless res xx = if res then mid () else xx
521 module Monad2FromT(B : TRANS2) : MONAD2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
522 include Monad2FromBind(struct
524 let mid x = hoist U.(mid x)
525 let map = `Generate let map2 = `Generate let mapply = `Generate
530 module Monad2FromTUZ(B : TRANSUZ2) : MONADZERO2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
531 include Monad2FromBind(struct
533 let mid x = hoist U.(mid x)
534 let map = `Generate let map2 = `Generate let mapply = `Generate
537 let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
538 let guard res = if res then mid () else mzero
541 module Monad2FromTZ(B : TRANSZ2) : MONADZERO2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
542 include Monad2FromBind(struct
544 let mid x = hoist U.(mid x)
545 let map = `Generate let map2 = `Generate let mapply = `Generate
549 let guard res = if res then mid () else mzero
555 module type OPTION = sig
556 include MONADZERO with type 'a result = 'a option
557 val test : ('a option -> bool) -> 'a t -> 'a t
560 module type OPTIONT = sig
562 include MONADT with type 'a result = 'a option uresult
563 val test : ('a option ut -> bool) -> 'a t -> 'a t
566 module Option = struct
568 module type EXTRA = sig
570 val test : ('a option (* U.t *) -> bool) -> 'a t -> 'a t
572 module type EXTRA2 = sig
574 val test : ('a option -> bool) -> ('a,'d) t -> ('a,'d) t
576 module M : OPTION = struct
577 include Make.MonadFromBind(struct
578 type 'a t = 'a option
579 type 'a result = 'a t let run xx = xx
580 let map = `Custom map let map2 = `Custom map2 let mapply = `Generate
582 (* val (>>=) : 'a option -> ('a -> 'b option) -> 'b option *)
583 let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
586 let guard res : unit t = if res then Some () else None
587 let test p xx = if p xx then xx else None
590 include MONADZERO2 with type ('a,'d) result = 'a option
591 include EXTRA2 with type ('a,'d) t := ('a,'d) t
593 include Make.Monad2FromBind(struct
594 type ('a,'d) t = 'a option
595 type ('a,'d) result = ('a,'d) t let run xx = xx
596 let map = `Custom map let map2 = `Custom map2 let mapply = `Generate
598 let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
601 let guard res : (unit,'d) t = if res then Some () else None
602 let test p xx = if p xx then xx else None
604 module T(U : MONAD) : OPTIONT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
605 include Make.MonadFromTZ(struct
607 type 'a t = 'a option U.t
608 type 'a result = 'a option U.result let run xx = U.run xx
609 let hoist uu = U.(uu >>= fun u -> mid (Some u))
610 let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None)
611 let mzero = Obj.magic U.(mid None)
613 let test p xx = if p xx then xx else U.mid None
615 module T2(U : MONAD2) : sig
616 include MONADZERO2T with type ('a,'d) result = ('a option, 'd) U.result and type ('a,'d) ut := ('a,'d) U.t
617 include EXTRA2 with type ('a,'d) t := ('a,'d) t
618 val test : (('a option,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t
620 include Make.Monad2FromTZ(struct
622 type ('a,'d) t = ('a option,'d) U.t
623 type ('a,'d) result = ('a option,'d) U.result let run xx = U.run xx
624 let hoist uu = U.(uu >>= fun u -> mid (Some u))
625 let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None)
626 let mzero = Obj.magic U.(mid None)
628 let test p xx = if p xx then xx else U.mid None
633 module type LIST = sig
634 include MONADZERO with type 'a result = 'a list
635 val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
636 val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *)
637 val test : ('a list -> bool) -> 'a t -> 'a t
640 module type LISTT = sig
642 include MONADZEROT with type 'a result = 'a list uresult
643 val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
644 val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *)
645 val test : ('a list ut -> bool) -> 'a t -> 'a t
647 Monadically seq k over box<a>.
648 OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
649 ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
650 TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
652 val distribute : ('a -> 'b ut) -> 'a list -> 'b t
657 module type EXTRA2 = sig
659 val (++) : ('a,'d) t -> ('a,'d) t -> ('a,'d) t
660 val pick : ('a,'d) t -> ('a * ('a,'d) t,'d) t
661 val test : ('a list -> bool) -> ('a,'d) t -> ('a,'d) t
663 module M : LIST = struct
664 include Make.MonadFromBind(struct
666 type 'a result = 'a t let run xx = xx
667 let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate
669 let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
672 let guard res : unit t = if res then [()] else []
673 (* (++) has tighter precedence than (>>=) *)
675 let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
676 let test p xx = if p xx then xx else []
679 include MONADZERO2 with type ('a,'d) result = 'a list
680 include EXTRA2 with type ('a,'d) t := ('a,'d) t
682 include Make.Monad2FromBind(struct
683 type ('a,'d) t = 'a list
684 type ('a,'d) result = ('a,'d) t let run xx = xx
685 let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate
687 let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
690 let guard res : (unit,'d) t = if res then [()] else []
692 let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
693 let test p xx = if p xx then xx else []
695 module T(U : MONAD) : LISTT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
696 let distribute k xs = U.seq (List.map k xs)
697 include Make.MonadFromTZ(struct
699 type 'a t = 'a list U.t
700 type 'a result = 'a list U.result let run xx = U.run xx
701 let hoist uu = U.(uu >>= fun u -> mid [u])
702 let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss))
703 let mzero = Obj.magic U.(mid [])
705 let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys))
706 let rec pick xx = U.(>>=) xx (function [] -> mzero | x::xs -> mid (x, U.(mid xs)) ++ (pick U.(mid xs) >>= fun (y,yy) -> mid (y, U.(yy >>= fun ys -> mid (x::ys)))))
707 let test p xx = if p xx then xx else U.mid []
709 module T2(U : MONAD2) : sig
710 include MONADZERO2T with type ('a,'d) result = ('a list,'d) U.result and type ('a,'d) ut := ('a,'d) U.t
711 include EXTRA2 with type ('a,'d) t := ('a,'d) t
712 val test : (('a list,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t
713 val distribute : ('a -> ('b,'d) U.t) -> 'a list -> ('b,'d) t
715 let distribute k xs = U.seq (List.map k xs)
716 include Make.Monad2FromTZ(struct
718 type ('a,'d) t = ('a list,'d) U.t
719 type ('a,'d) result = ('a list,'d) U.result let run xx = U.run xx
720 let hoist uu = U.(uu >>= fun u -> mid [u])
721 let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss))
722 let mzero = Obj.magic U.(mid [])
724 let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys))
725 let rec pick xx = U.(>>=) xx (function [] -> mzero | x::xs -> mid (x, U.(mid xs)) ++ (pick U.(mid xs) >>= fun (y,yy) -> mid (y, U.(yy >>= fun ys -> mid (x::ys)))))
726 let test p xx = if p xx then xx else U.mid []
731 (* LTree, unit centers, has natural ++ *)
732 (* ITree, unit leaves, has natural mzero *)
734 module type TREE = sig
736 include MONAD with type 'a result = 'a tree
737 val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
740 module type TREET = sig
743 include MONADT with type 'a result = 'a tree uresult
744 val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
746 Monadically seq k over box<a>.
747 OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
748 ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
749 TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
751 val distribute : ('a -> 'b ut) -> 'a tree -> 'b t
754 module LTree = struct
755 type 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree
756 let branch x y = Branch(x,y)
758 let traverse ((++) : 'b -> 'b -> 'b) (k : 'a -> 'b) (xt : 'a tree) : 'b =
759 let rec aux = function
761 | Branch(l, r) -> (* recursive application of k may delete a branch? *) aux l ++ aux r in
763 let map (f : 'a -> 'b) (xt : 'a tree) =
764 let rec aux = function
765 | Leaf x -> Leaf (f x)
766 | Branch(l, r) -> Branch(aux l, aux r) in
768 module M : TREE with type 'a tree := 'a tree = struct
769 include Make.MonadFromBind(struct
771 type 'a result = 'a t let run xx = xx
772 let map = `Custom map let map2 = `Generate let mapply = `Generate
774 let (>>=) xx k = traverse branch k xx
776 let (++) xx yy = Branch(xx, yy)
778 module T(U : MONAD) : TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
779 let hoist uu = U.(uu >>= fun u -> mid (Leaf u))
780 let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
781 include Make.MonadFromT(struct
783 type 'a t = 'a tree U.t
784 type 'a result = 'a tree U.result let run xx = U.run xx
786 let join xtt = traverse branch ident xtt
787 let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt)))
789 let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
791 module Z(U : MONADZERO) : sig
792 include TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
793 include ZERO with type 'a t := 'a t
795 let hoist uu = U.(uu >>= fun u -> mid (Leaf u))
796 let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
797 include Make.MonadFromTUZ(struct
799 type 'a t = 'a tree U.t
800 type 'a result = 'a tree U.result let run xx = U.run xx
802 let join xtt = traverse branch ident xtt
803 let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt)))
805 let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
810 module Identity = struct
812 include MONAD with type 'a result = 'a
814 include Make.MonadFromComp(struct
816 type 'a result = 'a t let run xx = xx
817 let map = `Custom (fun f x -> f x) let map2 = `Custom (fun f x y -> f x y) let mapply = `Custom (fun f x -> f x)
819 let (>=>) j k = fun x -> k (j x)
825 module type READER = sig
827 include MONAD with type 'a result = env -> 'a
829 val asks : (env -> 'a) -> 'a t
830 val shift : (env -> env) -> 'a t -> 'a t
833 module type READERT = sig
836 include MONADT with type 'a result = env -> 'a uresult
838 val asks : (env -> 'a) -> 'a t
839 val shift : (env -> env) -> 'a t -> 'a t
842 (* must be parameterized on `struct type env = ... end` *)
843 module Reader(E : sig type env end) = struct
845 module M : READER with type env := env = struct
846 include Make.MonadFromBind(struct
847 type 'a t = env -> 'a
848 type 'a result = 'a t let run xx = fun e -> xx e
849 let map = `Generate let map2 = `Generate let mapply = `Generate
850 let mid x = fun e -> x
851 let (>>=) xx k = fun e -> let x = xx e in let xx' = k x in xx' e
854 let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
855 let shift modifier xx = fun e -> xx (modifier e)
857 module T(U : MONAD) : READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
858 include Make.MonadFromT(struct
860 type 'a t = env -> 'a U.t
861 type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e)
862 let hoist uu = fun e -> uu
863 let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e)
866 let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
867 let shift modifier xx = fun e -> xx (modifier e)
869 module Z(U : MONADZERO) : sig
870 include READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
871 include ZERO with type 'a t := 'a t
873 include Make.MonadFromTUZ(struct
875 type 'a t = env -> 'a U.t
876 type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e)
877 let hoist uu = fun e -> uu
878 let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e)
881 let asks selector = ask >>= (fun e -> try mid (selector e) with Not_found -> mzero)
882 let shift modifier xx = fun e -> xx (modifier e)
887 module type STATE = sig
889 include MONAD with type 'a result = store -> 'a * store
891 val gets : (store -> 'a) -> 'a t
892 val put : store -> unit t
893 val modify : (store -> store) -> unit t
896 module type STATET = sig
899 include MONADT with type 'a result = store -> ('a * store) uresult
901 val gets : (store -> 'a) -> 'a t
902 val put : store -> unit t
903 val modify : (store -> store) -> unit t
906 (* must be parameterized on `struct type store = ... end` *)
907 module State(S : sig type store end) = struct
909 module M : STATE with type store := store = struct
910 include Make.MonadFromBind(struct
911 type 'a t = store -> 'a * store
912 type 'a result = 'a t let run xx = fun s -> xx s
913 let map = `Generate let map2 = `Generate let mapply = `Generate
914 let mid x = fun s -> x, s
915 let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s'
917 let get = fun s -> s,s
918 (* `gets viewer` is `map viewer get` *)
919 let gets viewer = fun s -> viewer s, s (* may fail with Not_found *)
920 let put s = fun _ -> (), s
921 let modify modifier = fun s -> (), modifier s
923 module T(U : MONAD) : STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
924 include Make.MonadFromT(struct
926 type 'a t = store -> ('a * store) U.t
927 type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s)
928 let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
929 let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
931 let get = fun s -> U.mid (s,s)
932 let gets viewer = fun s -> U.mid (viewer s, s) (* may fail with Not_found *)
933 let put s = fun _ -> U.mid ((), s)
934 let modify modifier = fun s -> U.mid ((), modifier s)
936 module Z(U : MONADZERO) : sig
937 include STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
938 include ZERO with type 'a t := 'a t
940 include Make.MonadFromTUZ(struct
942 type 'a t = store -> ('a * store) U.t
943 type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s)
944 let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
945 let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
947 let get = fun s -> U.mid (s,s)
948 let gets viewer = fun s -> try U.mid (viewer s, s) with Not_found -> mzero s
949 let put s = fun _ -> U.mid ((), s)
950 let modify modifier = fun s -> U.mid ((), modifier s)
955 module type REF = sig
958 include MONAD with type 'a result = 'a
959 val newref : value -> ref t
960 val deref : ref -> value t
961 val change : ref -> value -> unit t
964 module type REFT = sig
968 include MONADT with type 'a result = 'a uresult
969 val newref : value -> ref t
970 val deref : ref -> value t
971 val change : ref -> value -> unit t
974 (* State with a different interface; must be parameterized on `struct type value = ... end` *)
975 module Ref(V : sig type value end) = struct
978 module D = Map.Make(struct type t = ref let compare = compare end)
979 type dict = { next : ref; tree : value D.t }
980 let empty = { next = 0; tree = D.empty }
981 let alloc v d = d.next, { next = succ d.next; tree = D.add d.next v d.tree}
982 let read (k : ref) d = D.find k d.tree
983 let write (k : ref) v d = { next = d.next; tree = D.add k v d.tree }
984 module M : REF with type value := value and type ref := ref = struct
985 include Make.MonadFromBind(struct
986 type 'a t = dict -> 'a * dict
987 type 'a result = 'a let run xx = fst (xx empty)
988 let map = `Generate let map2 = `Generate let mapply = `Generate
989 let mid x = fun s -> x, s
990 let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s'
992 let newref v = fun s -> alloc v s
993 let deref k = fun s -> read k s, s (* shouldn't fail because k will have an abstract type? and we never GC *)
994 let change k v = fun s -> (), write k v s (* shouldn't allocate because k will have an abstract type *)
996 module T(U : MONAD) : REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
997 include Make.MonadFromT(struct
999 type 'a t = dict -> ('a * dict) U.t
1000 type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu
1001 let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
1002 let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
1004 let newref v = fun s -> U.mid (alloc v s)
1005 let deref k = fun s -> U.mid (read k s, s)
1006 let change k v = fun s -> U.mid ((), write k v s)
1008 module Z(U : MONADZERO) : sig
1009 include REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
1010 include ZERO with type 'a t := 'a t
1012 include Make.MonadFromTUZ(struct
1014 type 'a t = dict -> ('a * dict) U.t
1015 type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu
1016 let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
1017 let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
1019 let newref v = fun s -> U.mid (alloc v s)
1020 let deref k = fun s -> U.mid (read k s, s)
1021 let change k v = fun s -> U.mid ((), write k v s)
1026 module type WRITER = sig
1028 include MONAD with type 'a result = 'a * log
1029 val listen : 'a t -> ('a * log) t
1030 val listens : (log -> 'b) -> 'a t -> ('a * 'b) t
1031 val tell : log -> unit t
1032 (* val pass : ('a * (log -> log)) t -> 'a t *)
1033 val censor : (log -> log) -> 'a t -> 'a t
1036 module type WRITERT = sig
1039 include MONADT with type 'a result = ('a * log) uresult
1040 val listen : 'a t -> ('a * log) t
1041 val listens : (log -> 'b) -> 'a t -> ('a * 'b) t
1042 val tell : log -> unit t
1043 (* val pass : ('a * (log -> log)) t -> 'a t *)
1044 val censor : (log -> log) -> 'a t -> 'a t
1047 (* must be parameterized on `struct type log = ... end` *)
1048 module Writer(W : sig type log val empty : log val append : log -> log -> log end) = struct
1050 module M : WRITER with type log := log = struct
1051 include Make.MonadFromBind(struct
1052 type 'a t = 'a * log
1053 type 'a result = 'a t let run xx = xx
1054 let map = `Generate let map2 = `Generate let mapply = `Generate
1055 let mid x = x, W.empty
1056 let (>>=) (x,w) k = let (y,w') = k x in (y, W.append w w')
1058 let listen (x,w) = (x,w), w
1059 let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w) (* filter listen through selector *)
1060 let tell entries = (), entries (* add to log *)
1061 let pass ((x,c),w) = (x, c w) (* usually use censor *)
1062 let censor c xx = pass (xx >>= fun x -> mid (x,c)) (* ==> (x, c w) *)
1064 module T(U : MONAD) : WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
1065 include Make.MonadFromT(struct
1067 type 'a t = ('a * log) U.t
1068 type 'a result = ('a * log) U.result let run xx = U.run xx
1069 let hoist uu = U.(uu >>= fun u -> mid (u, W.empty))
1070 let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w'))
1072 let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w))
1073 let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w)
1074 let tell entries = U.mid ((), entries)
1075 let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w))
1076 let censor c xx = pass (xx >>= fun x -> mid (x,c))
1078 module Z(U : MONADZERO) : sig
1079 include WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
1080 include ZERO with type 'a t := 'a t
1082 include Make.MonadFromTUZ(struct
1084 type 'a t = ('a * log) U.t
1085 type 'a result = ('a * log) U.result let run xx = U.run xx
1086 let hoist uu = U.(uu >>= fun u -> mid (u, W.empty))
1087 let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w'))
1089 let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w))
1090 let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w)
1091 let tell entries = U.mid ((), entries)
1092 let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w))
1093 let censor c xx = pass (xx >>= fun x -> mid (x,c))
1098 module type ERROR = sig
1101 include MONAD with type 'a result = 'a error
1102 val throw : msg -> 'a t
1103 val catch : 'a t -> (msg -> 'a t) -> 'a t
1106 module type ERRORT = sig
1110 include MONADT with type 'a result = 'a uresult (* note the difference from ERROR *)
1111 val throw : msg -> 'a t
1112 val catch : 'a t -> (msg -> 'a t) -> 'a t
1115 (* must be parameterized on `struct type msg = ... end` *)
1116 module Error(E : sig type msg exception Exc of msg (* Exc used only by T *) end) = struct
1118 type 'a error = Error of msg | OK of 'a
1119 module M : ERROR with type msg := msg and type 'a error := 'a error = struct
1120 include Make.MonadFromBind(struct
1121 type 'a t = 'a error
1122 type 'a result = 'a t
1123 (* note that M.run doesn't raise *)
1125 let map = `Generate let map2 = `Generate let mapply = `Generate
1127 let (>>=) xx k = match xx with OK x -> k x | Error e -> Error e
1129 let throw e = Error e
1130 let catch xx handler = match xx with OK _ -> xx | Error e -> handler e
1132 module T(U : MONAD) : ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
1133 include Make.MonadFromT(struct
1135 type 'a t = 'a error U.t
1136 type 'a result = 'a U.result
1137 (* note that T.run does raise *)
1138 let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> raise (E.Exc e)) in U.run uu
1139 let hoist uu = U.(uu >>= fun u -> mid (OK u))
1140 let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
1142 let throw e = U.mid (Error e)
1143 let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
1145 module Z(U : MONADZERO) : sig
1146 include ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
1147 include ZERO with type 'a t := 'a t
1149 include Make.MonadFromTUZ(struct
1151 type 'a t = 'a error U.t
1152 type 'a result = 'a U.result
1153 (* we recover from error by using U's mzero; but this discards the error msg *)
1154 let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> mzero) in U.run uu
1155 let hoist uu = U.(uu >>= fun u -> mid (OK u))
1156 let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
1158 let throw e = U.mid (Error e)
1159 let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
1164 (* predefine some common instances *)
1166 module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = if s2 = "" then s1 else if s1 = "" then s2 else s1 ^ "\n" ^ s2 end)
1168 module Writer2 = struct
1169 include Writer(struct
1170 type log = string list
1172 let append s1 s2 = List.append s2 s1
1174 (* FIXME these aren't inside M *)
1175 let tell_string s = M.tell [s]
1176 let tell entries = M.tell (List.rev entries)
1177 let run xx = let (x,w) = M.run xx in (x, List.rev w)
1180 module Failure = Error(struct type msg = string exception Exc = Failure end)
1184 module Option = Monad.Option
1185 module List = Monad.List