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 MONADZERO = 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 MONADZEROT = sig
51 val hoist : 'a ut -> 'a t
54 module type MAPPABLE2 = sig
56 val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
59 module type APPLICATIVE2 = sig
61 val mid : 'a -> ('a,'d) t
62 val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t
63 val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t
64 val (>>) : ('a,'d) t -> ('b,'d) t -> ('b,'d) t
65 val (<<) : ('a,'d) t -> ('b,'d) t -> ('a,'d) t
68 module type MONAD2 = sig
71 val run : ('a,'d) t -> ('a,'d) result
72 val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
73 val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t)
74 val (<=<) : ('b -> ('c,'d) t) -> ('a -> ('b,'d) t) -> ('a -> ('c,'d) t)
75 val join : (('a,'d) t,'d) t -> ('a,'d) t
76 val ignore : ('a,'d) t -> (unit,'d) t
77 val seq : ('a,'d) t list -> ('a list,'d) t
78 val seq_ignore : (unit,'d) t list -> (unit,'d) t
79 val do_when : bool -> (unit,'d) t -> (unit,'d) t
80 val do_unless : bool -> (unit,'d) t -> (unit,'d) t
83 module type MONAD2T = sig
86 val hoist : ('a,'d) ut -> ('a,'d) t
89 module type MONADZERO2 = sig
92 val guard : bool -> (unit,'d) t
95 module type MONADZERO2T = sig
98 val hoist : ('a,'d) ut -> ('a,'d) t
103 module type MAP2 = sig
106 val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
107 val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
108 val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
111 module type MAPPLY = sig
114 val mapply : ('a -> 'b) t -> 'a t -> 'b t
115 val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
116 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
119 module type BIND = sig
122 val run : 'a t -> 'a result
124 val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
125 val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
126 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
127 val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
130 module type COMP = sig
133 val run : 'a t -> 'a result
135 val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t)
136 val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
137 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
138 val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
141 module type JOIN = sig
144 val run : 'a t -> 'a result
146 val join : 'a t t -> 'a t
147 val map : ('a -> 'b) -> 'a t -> 'b t
148 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
149 val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
152 module type TRANS = sig
156 val run : 'a t -> 'a result
157 (* Provide hoist, >>=; LAWS: 1. hoist U.(mid x) == mid x; 2. hoist U.(uu >>= k) == hoist uu >>= fun u -> hoist (k u) *)
158 val hoist : 'a U.t -> 'a t
159 val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
162 module type TRANSUZ = sig
166 val run : 'a t -> 'a result
167 val hoist : 'a U.t -> 'a t
168 val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
171 module type TRANSZ = sig
175 val run : 'a t -> 'a result
176 val hoist : 'a U.t -> 'a t
177 val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
181 module ApplicativeFromBind(B : BIND) : APPLICATIVE with type 'a t = 'a B.t = struct
185 let map = match B.map with
187 | `Generate -> fun f xx -> xx >>= fun x -> mid (f x)
188 let map2 = match B.map2 with
189 | `Custom map2 -> map2
190 | `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y)
191 let mapply = match B.map2 with
192 | `Custom map2 -> fun eta -> map2 ident eta
193 | `Generate -> fun ff xx -> ff >>= fun f -> map f xx
194 let (>>) xx yy = xx >>= fun _ -> yy
195 let (<<) xx yy = mapply (map const xx) yy
198 module ApplicativeFromMap2(B : MAP2) : APPLICATIVE with type 'a t = 'a B.t = struct
202 let mapply = match B.mapply with
203 | `Custom mapply -> mapply
204 | `Generate -> fun eta -> map2 ident eta
205 let map = match B.map with
207 | `Generate -> fun f xx -> mapply (mid f) xx
208 let (>>) xx yy = mapply (map (const ident) xx) yy
209 let (<<) xx yy = mapply (map const xx) yy
212 module ApplicativeFromApply(B : MAPPLY) : APPLICATIVE with type 'a t = 'a B.t = struct
215 let mapply = B.mapply
216 let map = match B.map with
218 | `Generate -> fun f xx -> mapply (mid f) xx
219 let map2 = match B.map2 with
220 | `Custom map2 -> map2
221 | `Generate -> fun f xx yy -> mapply (map f xx) yy
222 let (>>) xx yy = mapply (map (const ident) xx) yy
223 let (<<) xx yy = mapply (map const xx) yy
226 module MonadFromBind(B : BIND) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
228 include ApplicativeFromBind(B)
229 type 'a result = 'a B.result
231 let (>=>) j k = fun a -> j a >>= k
232 let (<=<) k j = fun a -> j a >>= k
233 let join xxx = xxx >>= ident
234 let ignore xx = map (fun _ -> ()) xx
235 (* seq xxs = let f xx zzf = (xx >>=) . flip ((zzf.).(:)) in foldr f (return $) xxs [] *)
237 foldr' f z xs = foldl (\g x z -> g (f x z)) id xs z -- foldr but evaluating from left?
238 foldl'' f z xs = foldr (\x g z -> g (f z x)) id xs z -- foldl but evaluating from right? these don't work
239 -- with foldr, evaluates left->right; with foldl the reverse
241 let f c xx ret xs = xx >>= ret . c xs in -- careful! isn't fmap (c xs) xx because ret isn't (always) return
242 reverse <$> foldr (f $ flip (:)) return xxs []
243 -- or simply: foldr (f snoc) return xxs []
246 let rec aux xs = function
247 | [] -> mid (List.rev xs)
248 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
249 fun xxs -> aux [] xxs
250 let rec seq_ignore = function
252 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
253 let do_when res xx = if res then xx else mid ()
254 let do_unless res xx = if res then mid () else xx
257 module MonadFromComp(B : COMP) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
259 let (<=<) k j = j >=> k
260 let (>>=) xx k = (ident >=> k) xx
261 include ApplicativeFromBind(struct include B let (>>=) = (>>=) end)
262 type 'a result = 'a B.result
264 let join xxx = xxx >>= ident
265 let ignore xx = map (fun _ -> ()) xx
267 let rec aux xs = function
268 | [] -> mid (List.rev xs)
269 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
270 fun xxs -> aux [] xxs
271 let rec seq_ignore = function
273 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
274 let do_when res xx = if res then xx else mid ()
275 let do_unless res xx = if res then mid () else xx
278 module MonadFromJoin(B : JOIN) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
280 let (>>=) xx k = join (B.map k xx)
281 include ApplicativeFromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end)
282 type 'a result = 'a B.result
284 let (>=>) j k = fun a -> j a >>= k
285 let (<=<) k j = fun a -> j a >>= k
286 let ignore xx = map (fun _ -> ()) xx
288 let rec aux xs = function
289 | [] -> mid (List.rev xs)
290 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
291 fun xxs -> aux [] xxs
292 let rec seq_ignore = function
294 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
295 let do_when res xx = if res then xx else mid ()
296 let do_unless res xx = if res then mid () else xx
299 module MonadFromT(B : TRANS) : MONADT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
300 include MonadFromBind(struct
302 let mid x = hoist U.(mid x)
303 let map = `Generate let map2 = `Generate let mapply = `Generate
308 module MonadFromTUZ(B : TRANSUZ) : MONADZEROT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
309 let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
310 include MonadFromBind(struct
312 let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
313 let mid x = hoist U.(mid x)
314 let map = `Generate let map2 = `Generate let mapply = `Generate
317 let guard res = if res then mid () else mzero
320 module MonadFromTZ(B : TRANSZ) : MONADZEROT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
321 include MonadFromBind(struct
323 let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
324 let mid x = hoist U.(mid x)
325 let map = `Generate let map2 = `Generate let mapply = `Generate
329 let guard res = if res then mid () else mzero
332 module type BIND2 = sig
335 val run : ('a,'d) t -> ('a,'d) result
336 val mid : 'a -> ('a,'d) t
337 val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
338 val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
339 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
340 val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
343 module type COMP2 = sig
346 val run : ('a,'d) t -> ('a,'d) result
347 val mid : 'a -> ('a,'d) t
348 val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t)
349 val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
350 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
351 val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
354 module type JOIN2 = sig
357 val run : ('a,'d) t -> ('a,'d) result
358 val mid : 'a -> ('a,'d) t
359 val join : (('a,'d) t,'d) t -> ('a,'d) t
360 val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
361 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
362 val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
365 module type TRANS2 = sig
369 val run : ('a,'d) t -> ('a,'d) result
370 val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
371 val hoist : ('a,'d) U.t -> ('a,'d) t
374 module type TRANSUZ2 = sig
375 module U : MONADZERO2
378 val run : ('a,'d) t -> ('a,'d) result
379 val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
380 val hoist : ('a,'d) U.t -> ('a,'d) t
383 module type TRANSZ2 = sig
387 val run : ('a,'d) t -> ('a,'d) result
388 val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
389 val hoist : ('a,'d) U.t -> ('a,'d) t
390 val mzero : ('a,'d) t
393 module type MAP22 = sig
395 val mid : 'a -> ('a,'d) t
396 val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t
397 val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
398 val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
401 module type MAPPLY2 = sig
403 val mid : 'a -> ('a,'d) t
404 val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t
405 val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
406 val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
409 module Applicative2FromBind(B : BIND2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
410 type ('a,'d) t = ('a,'d) B.t
413 let map = match B.map with
415 | `Generate -> fun f xx -> xx >>= fun x -> mid (f x)
416 let map2 = match B.map2 with
417 | `Custom map2 -> map2
418 | `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y)
419 let mapply = match B.map2 with
420 | `Custom map2 -> fun eta -> map2 ident eta
421 | `Generate -> fun ff xx -> ff >>= fun f -> map f xx
422 let (>>) xx yy = xx >>= fun _ -> yy
423 let (<<) xx yy = mapply (map const xx) yy
426 module Applicative2FromMap2(B : MAP22) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
427 type ('a,'d) t = ('a,'d) B.t
430 let mapply = match B.mapply with
431 | `Custom mapply -> mapply
432 | `Generate -> fun eta -> map2 ident eta
433 let map = match B.map with
435 | `Generate -> fun f xx -> mapply (mid f) xx
436 let (>>) xx yy = mapply (map (const ident) xx) yy
437 let (<<) xx yy = mapply (map const xx) yy
440 module Applicative2FromApply(B : MAPPLY2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
441 type ('a,'d) t = ('a,'d) B.t
443 let mapply = B.mapply
444 let map = match B.map with
446 | `Generate -> fun f xx -> mapply (mid f) xx
447 let map2 = match B.map2 with
448 | `Custom map2 -> map2
449 | `Generate -> fun f xx yy -> mapply (map f xx) yy
450 let (>>) xx yy = mapply (map (const ident) xx) yy
451 let (<<) xx yy = mapply (map const xx) yy
454 module Monad2FromBind(B : BIND2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
456 include Applicative2FromBind(B)
457 type ('a,'d) result = ('a,'d) B.result
459 let (>=>) j k = fun a -> j a >>= k
460 let (<=<) k j = fun a -> j a >>= k
461 let join xxx = xxx >>= ident
462 let ignore xx = map (fun _ -> ()) xx
464 let rec aux xs = function
465 | [] -> mid (List.rev xs)
466 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
467 fun xxs -> aux [] xxs
468 let rec seq_ignore = function
470 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
471 let do_when res xx = if res then xx else mid ()
472 let do_unless res xx = if res then mid () else xx
475 module Monad2FromComp(B : COMP2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
477 let (<=<) k j = j >=> k
478 let (>>=) xx k = (ident >=> k) xx
479 include Applicative2FromBind(struct include B let (>>=) = (>>=) end)
480 type ('a,'d) result = ('a,'d) B.result
482 let join xxx = xxx >>= ident
483 let ignore xx = map (fun _ -> ()) xx
485 let rec aux xs = function
486 | [] -> mid (List.rev xs)
487 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
488 fun xxs -> aux [] xxs
489 let rec seq_ignore = function
491 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
492 let do_when res xx = if res then xx else mid ()
493 let do_unless res xx = if res then mid () else xx
496 module Monad2FromJoin(B : JOIN2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
498 let (>>=) xx k = join (B.map k xx)
499 include Applicative2FromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end)
500 type ('a,'d) result = ('a,'d) B.result
502 let (>=>) j k = fun a -> j a >>= k
503 let (<=<) k j = fun a -> j a >>= k
504 let ignore xx = map (fun _ -> ()) xx
506 let rec aux xs = function
507 | [] -> mid (List.rev xs)
508 | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
509 fun xxs -> aux [] xxs
510 let rec seq_ignore = function
512 | xx::xxs -> xx >>= fun () -> seq_ignore xxs
513 let do_when res xx = if res then xx else mid ()
514 let do_unless res xx = if res then mid () else xx
517 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
518 include Monad2FromBind(struct
520 let mid x = hoist U.(mid x)
521 let map = `Generate let map2 = `Generate let mapply = `Generate
526 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
527 include Monad2FromBind(struct
529 let mid x = hoist U.(mid x)
530 let map = `Generate let map2 = `Generate let mapply = `Generate
533 let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
534 let guard res = if res then mid () else mzero
537 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
538 include Monad2FromBind(struct
540 let mid x = hoist U.(mid x)
541 let map = `Generate let map2 = `Generate let mapply = `Generate
545 let guard res = if res then mid () else mzero
552 module Option = struct
554 module type EXTRA = sig
556 val test : ('a option (* U.t *) -> bool) -> 'a t -> 'a t
558 module type EXTRA2 = sig
560 val test : ('a option -> bool) -> ('a,'d) t -> ('a,'d) t
563 include MONADZERO with type 'a result = 'a option
564 include EXTRA with type 'a t := 'a t
566 include Make.MonadFromBind(struct
567 type 'a t = 'a option
568 type 'a result = 'a t let run xx = xx
569 let map = `Custom map let map2 = `Custom map2 let mapply = `Generate
571 (* val (>>=) : 'a option -> ('a -> 'b option) -> 'b option *)
572 let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
575 let guard res : unit t = if res then Some () else None
576 let test p xx = if p xx then xx else None
579 include MONADZERO2 with type ('a,'d) result = 'a option
580 include EXTRA2 with type ('a,'d) t := ('a,'d) t
582 include Make.Monad2FromBind(struct
583 type ('a,'d) t = 'a option
584 type ('a,'d) result = ('a,'d) t let run xx = xx
585 let map = `Custom map let map2 = `Custom map2 let mapply = `Generate
587 let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
590 let guard res : (unit,'d) t = if res then Some () else None
591 let test p xx = if p xx then xx else None
593 module T(U : MONAD) : sig
594 include MONADZEROT with type 'a result = 'a option U.result and type 'a ut := 'a U.t
595 include EXTRA with type 'a t := 'a t
596 val test : ('a option U.t -> bool) -> 'a t -> 'a t
598 include Make.MonadFromTZ(struct
600 type 'a t = 'a option U.t
601 type 'a result = 'a option U.result let run xx = U.run xx
602 let hoist uu = U.(uu >>= fun u -> mid (Some u))
603 let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None)
604 let mzero = Obj.magic U.(mid None)
606 let test p xx = if p xx then xx else U.mid None
608 module T2(U : MONAD2) : sig
609 include MONADZERO2T with type ('a,'d) result = ('a option, 'd) U.result and type ('a,'d) ut := ('a,'d) U.t
610 include EXTRA2 with type ('a,'d) t := ('a,'d) t
611 val test : (('a option,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t
613 include Make.Monad2FromTZ(struct
615 type ('a,'d) t = ('a option,'d) U.t
616 type ('a,'d) result = ('a option,'d) U.result let run xx = U.run xx
617 let hoist uu = U.(uu >>= fun u -> mid (Some u))
618 let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None)
619 let mzero = Obj.magic U.(mid None)
621 let test p xx = if p xx then xx else U.mid None
627 module type EXTRA = sig
629 val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
630 val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *)
631 val test : ('a list (* U.t *) -> bool) -> 'a t -> 'a t
633 module type EXTRA2 = sig
635 val (++) : ('a,'d) t -> ('a,'d) t -> ('a,'d) t
636 val pick : ('a,'d) t -> ('a * ('a,'d) t,'d) t
637 val test : ('a list -> bool) -> ('a,'d) t -> ('a,'d) t
640 include MONADZERO with type 'a result = 'a list
641 include EXTRA with type 'a t := 'a t
643 include Make.MonadFromBind(struct
645 type 'a result = 'a t let run xx = xx
646 let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate
648 let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
651 let guard res : unit t = if res then [()] else []
652 (* (++) has tighter precedence than (>>=) *)
654 let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
655 let test p xx = if p xx then xx else []
658 include MONADZERO2 with type ('a,'d) result = 'a list
659 include EXTRA2 with type ('a,'d) t := ('a,'d) t
661 include Make.Monad2FromBind(struct
662 type ('a,'d) t = 'a list
663 type ('a,'d) result = ('a,'d) t let run xx = xx
664 let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate
666 let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
669 let guard res : (unit,'d) t = if res then [()] else []
671 let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
672 let test p xx = if p xx then xx else []
674 module T(U : MONAD) : sig
675 include MONADZEROT with type 'a result = 'a list U.result and type 'a ut := 'a U.t
676 include EXTRA with type 'a t := 'a t
677 val test : ('a list U.t -> bool) -> 'a t -> 'a t
679 Monadically seq k over box<a>.
680 OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
681 ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
682 TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
684 val distribute : ('a -> 'b U.t) -> 'a list -> 'b t
686 let distribute k xs = U.seq (List.map k xs)
687 include Make.MonadFromTZ(struct
689 type 'a t = 'a list U.t
690 type 'a result = 'a list U.result let run xx = U.run xx
691 let hoist uu = U.(uu >>= fun u -> mid [u])
692 let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss))
693 let mzero = Obj.magic U.(mid [])
695 let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys))
696 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)))))
697 let test p xx = if p xx then xx else U.mid []
699 module T2(U : MONAD2) : sig
700 include MONADZERO2T with type ('a,'d) result = ('a list,'d) U.result and type ('a,'d) ut := ('a,'d) U.t
701 include EXTRA2 with type ('a,'d) t := ('a,'d) t
702 val test : (('a list,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t
703 val distribute : ('a -> ('b,'d) U.t) -> 'a list -> ('b,'d) t
705 let distribute k xs = U.seq (List.map k xs)
706 include Make.Monad2FromTZ(struct
708 type ('a,'d) t = ('a list,'d) U.t
709 type ('a,'d) result = ('a list,'d) U.result let run xx = U.run xx
710 let hoist uu = U.(uu >>= fun u -> mid [u])
711 let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss))
712 let mzero = Obj.magic U.(mid [])
714 let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys))
715 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)))))
716 let test p xx = if p xx then xx else U.mid []
721 (* LTree, unit centers, has natural ++ *)
722 (* ITree, unit leaves, has natural mzero *)
724 module LTree = struct
725 type 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree
726 let branch x y = Branch(x,y)
728 let traverse ((++) : 'b -> 'b -> 'b) (k : 'a -> 'b) (xt : 'a tree) : 'b =
729 let rec aux = function
731 | Branch(l, r) -> (* recursive application of k may delete a branch? *) aux l ++ aux r in
733 let map (f : 'a -> 'b) (xt : 'a tree) =
734 let rec aux = function
735 | Leaf x -> Leaf (f x)
736 | Branch(l, r) -> Branch(aux l, aux r) in
738 module type EXTRA = sig
740 val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
743 include MONAD with type 'a result = 'a tree
744 include EXTRA with type 'a t := 'a t
746 include Make.MonadFromBind(struct
748 type 'a result = 'a t let run xx = xx
749 let map = `Custom map let map2 = `Generate let mapply = `Generate
751 let (>>=) xx k = traverse branch k xx
753 let (++) xx yy = Branch(xx, yy)
755 module T(U : MONAD) : sig
756 include MONADT with type 'a result = 'a tree U.result and type 'a ut := 'a U.t
757 include EXTRA with type 'a t := 'a t
759 Monadically seq k over box<a>.
760 OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
761 ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
762 TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
764 val distribute : ('a -> 'b U.t) -> 'a tree -> 'b t
766 let hoist uu = U.(uu >>= fun u -> mid (Leaf u))
767 let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
768 include Make.MonadFromT(struct
770 type 'a t = 'a tree U.t
771 type 'a result = 'a tree U.result let run xx = U.run xx
773 let join xtt = traverse branch ident xtt
774 let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt)))
776 let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
778 module Z(U : MONADZERO) : sig
779 include MONADZEROT with type 'a result = 'a tree U.result and type 'a ut := 'a U.t
780 include EXTRA with type 'a t := 'a t
781 val distribute : ('a -> 'b U.t) -> 'a tree -> 'b t
783 let hoist uu = U.(uu >>= fun u -> mid (Leaf u))
784 let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
785 include Make.MonadFromTUZ(struct
787 type 'a t = 'a tree U.t
788 type 'a result = 'a tree U.result let run xx = U.run xx
790 let join xtt = traverse branch ident xtt
791 let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt)))
793 let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
798 module Identity = struct
800 include MONAD with type 'a result = 'a
802 include Make.MonadFromComp(struct
804 type 'a result = 'a t let run xx = xx
805 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)
807 let (>=>) j k = fun x -> k (j x)
812 (* must be parameterized on `struct type env = ... end` *)
813 module Reader(E : sig type env end) = struct
815 module type EXTRA = sig
818 val asks : (env -> 'a) -> 'a t
819 val shift : (env -> env) -> 'a t -> 'a t
822 include MONAD with type 'a result = env -> 'a
823 include EXTRA with type 'a t := 'a t
825 include Make.MonadFromBind(struct
826 type 'a t = env -> 'a
827 type 'a result = 'a t let run xx = fun e -> xx e
828 let map = `Generate let map2 = `Generate let mapply = `Generate
829 let mid x = fun e -> x
830 let (>>=) xx k = fun e -> let x = xx e in let xx' = k x in xx' e
833 let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
834 let shift modifier xx = fun e -> xx (modifier e)
836 module T(U : MONAD) : sig
837 include MONADT with type 'a result = env -> 'a U.result and type 'a ut := 'a U.t
838 include EXTRA with type 'a t := 'a t
840 include Make.MonadFromT(struct
842 type 'a t = env -> 'a U.t
843 type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e)
844 let hoist uu = fun e -> uu
845 let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e)
848 let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
849 let shift modifier xx = fun e -> xx (modifier e)
851 module Z(U : MONADZERO) : sig
852 include MONADZEROT with type 'a result = env -> 'a U.result and type 'a ut := 'a U.t
853 include EXTRA with type 'a t := 'a t
855 include Make.MonadFromTUZ(struct
857 type 'a t = env -> 'a U.t
858 type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e)
859 let hoist uu = fun e -> uu
860 let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e)
863 let asks selector = ask >>= (fun e -> try mid (selector e) with Not_found -> mzero)
864 let shift modifier xx = fun e -> xx (modifier e)
868 (* must be parameterized on `struct type store = ... end` *)
869 module State(S : sig type store end) = struct
871 module type EXTRA = sig
874 val gets : (store -> 'a) -> 'a t
875 val put : store -> unit t
876 val modify : (store -> store) -> unit t
879 include MONAD with type 'a result = store -> 'a * store
880 include EXTRA with type 'a t := 'a t
882 include Make.MonadFromBind(struct
883 type 'a t = store -> 'a * store
884 type 'a result = 'a t let run xx = fun s -> xx s
885 let map = `Generate let map2 = `Generate let mapply = `Generate
886 let mid x = fun s -> x, s
887 let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s'
889 let get = fun s -> s,s
890 (* `gets viewer` is `map viewer get` *)
891 let gets viewer = fun s -> viewer s, s (* may fail with Not_found *)
892 let put s = fun _ -> (), s
893 let modify modifier = fun s -> (), modifier s
895 module T(U : MONAD) : sig
896 include MONADT with type 'a result = store -> ('a * store) U.result and type 'a ut := 'a U.t
897 include EXTRA with type 'a t := 'a t
899 include Make.MonadFromT(struct
901 type 'a t = store -> ('a * store) U.t
902 type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s)
903 let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
904 let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
906 let get = fun s -> U.mid (s,s)
907 let gets viewer = fun s -> U.mid (viewer s, s) (* may fail with Not_found *)
908 let put s = fun _ -> U.mid ((), s)
909 let modify modifier = fun s -> U.mid ((), modifier s)
911 module Z(U : MONADZERO) : sig
912 include MONADZEROT with type 'a result = store -> ('a * store) U.result and type 'a ut := 'a U.t
913 include EXTRA with type 'a t := 'a t
915 include Make.MonadFromTUZ(struct
917 type 'a t = store -> ('a * store) U.t
918 type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s)
919 let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
920 let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
922 let get = fun s -> U.mid (s,s)
923 let gets viewer = fun s -> try U.mid (viewer s, s) with Not_found -> mzero s
924 let put s = fun _ -> U.mid ((), s)
925 let modify modifier = fun s -> U.mid ((), modifier s)
929 (* State with a different interface; must be parameterized on `struct type value = ... end` *)
930 module Ref(V : sig type value end) = struct
933 module D = Map.Make(struct type t = ref let compare = compare end)
934 type dict = { next : ref; tree : value D.t }
935 let empty = { next = 0; tree = D.empty }
936 let alloc v d = d.next, { next = succ d.next; tree = D.add d.next v d.tree}
937 let read (k : ref) d = D.find k d.tree
938 let write (k : ref) v d = { next = d.next; tree = D.add k v d.tree }
939 module type EXTRA = sig
941 val newref : value -> ref t
942 val deref : ref -> value t
943 val change : ref -> value -> unit t
946 include MONAD with type 'a result = 'a
947 include EXTRA with type 'a t := 'a t
949 include Make.MonadFromBind(struct
950 type 'a t = dict -> 'a * dict
951 type 'a result = 'a let run xx = fst (xx empty)
952 let map = `Generate let map2 = `Generate let mapply = `Generate
953 let mid x = fun s -> x, s
954 let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s'
956 let newref v = fun s -> alloc v s
957 let deref k = fun s -> read k s, s (* shouldn't fail because k will have an abstract type? and we never GC *)
958 let change k v = fun s -> (), write k v s (* shouldn't allocate because k will have an abstract type *)
960 module T(U : MONAD) : sig
961 include MONADT with type 'a result = 'a U.result and type 'a ut := 'a U.t
962 include EXTRA with type 'a t := 'a t
964 include Make.MonadFromT(struct
966 type 'a t = dict -> ('a * dict) U.t
967 type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu
968 let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
969 let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
971 let newref v = fun s -> U.mid (alloc v s)
972 let deref k = fun s -> U.mid (read k s, s)
973 let change k v = fun s -> U.mid ((), write k v s)
975 module Z(U : MONADZERO) : sig
976 include MONADZEROT with type 'a result = 'a U.result and type 'a ut := 'a U.t
977 include EXTRA with type 'a t := 'a t
979 include Make.MonadFromTUZ(struct
981 type 'a t = dict -> ('a * dict) U.t
982 type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu
983 let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
984 let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
986 let newref v = fun s -> U.mid (alloc v s)
987 let deref k = fun s -> U.mid (read k s, s)
988 let change k v = fun s -> U.mid ((), write k v s)
992 (* must be parameterized on `struct type log = ... end` *)
993 module Writer(W : sig type log val empty : log val append : log -> log -> log end) = struct
995 module type EXTRA = sig
997 val listen : 'a t -> ('a * log) t
998 val listens : (log -> 'b) -> 'a t -> ('a * 'b) t
999 val tell : log -> unit t
1000 (* val pass : ('a * (log -> log)) t -> 'a t *)
1001 val censor : (log -> log) -> 'a t -> 'a t
1004 include MONAD with type 'a result = 'a * log
1005 include EXTRA with type 'a t := 'a t
1007 include Make.MonadFromBind(struct
1008 type 'a t = 'a * log
1009 type 'a result = 'a t let run xx = xx
1010 let map = `Generate let map2 = `Generate let mapply = `Generate
1011 let mid x = x, W.empty
1012 let (>>=) (x,w) k = let (y,w') = k x in (y, W.append w w')
1014 let listen (x,w) = (x,w), w
1015 let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w) (* filter listen through selector *)
1016 let tell entries = (), entries (* add to log *)
1017 let pass ((x,c),w) = (x, c w) (* usually use censor *)
1018 let censor c xx = pass (xx >>= fun x -> mid (x,c)) (* ==> (x, c w) *)
1020 module T(U : MONAD) : sig
1021 include MONADT with type 'a result = ('a * log) U.result and type 'a ut := 'a U.t
1022 include EXTRA with type 'a t := 'a t
1024 include Make.MonadFromT(struct
1026 type 'a t = ('a * log) U.t
1027 type 'a result = ('a * log) U.result let run xx = U.run xx
1028 let hoist uu = U.(uu >>= fun u -> mid (u, W.empty))
1029 let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w'))
1031 let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w))
1032 let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w)
1033 let tell entries = U.mid ((), entries)
1034 let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w))
1035 let censor c xx = pass (xx >>= fun x -> mid (x,c))
1037 module Z(U : MONADZERO) : sig
1038 include MONADZEROT with type 'a result = ('a * log) U.result and type 'a ut := 'a U.t
1039 include EXTRA with type 'a t := 'a t
1041 include Make.MonadFromTUZ(struct
1043 type 'a t = ('a * log) U.t
1044 type 'a result = ('a * log) U.result let run xx = U.run xx
1045 let hoist uu = U.(uu >>= fun u -> mid (u, W.empty))
1046 let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w'))
1048 let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w))
1049 let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w)
1050 let tell entries = U.mid ((), entries)
1051 let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w))
1052 let censor c xx = pass (xx >>= fun x -> mid (x,c))
1056 (* must be parameterized on `struct type err = ... end` *)
1057 module Error(E : sig type err exception Exc of err end) = struct
1059 type 'a error = Error of err | OK of 'a
1060 module type EXTRA = sig
1062 val throw : err -> 'a t
1063 val catch : 'a t -> (err -> 'a t) -> 'a t
1066 include MONAD with type 'a result = 'a error
1067 include EXTRA with type 'a t := 'a t
1069 include Make.MonadFromBind(struct
1070 type 'a t = 'a error
1071 type 'a result = 'a t let run xx = xx
1072 let map = `Generate let map2 = `Generate let mapply = `Generate
1074 let (>>=) xx k = match xx with OK x -> k x | Error e -> Error e
1076 let throw e = Error e
1077 let catch xx handler = match xx with OK _ -> xx | Error e -> handler e
1079 module T(U : MONAD) : sig
1080 include MONADT with type 'a result = 'a U.result and type 'a ut := 'a U.t
1081 include EXTRA with type 'a t := 'a t
1083 include Make.MonadFromT(struct
1085 type 'a t = 'a error U.t
1086 type 'a result = 'a U.result
1087 let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> raise (E.Exc e)) in U.run uu
1088 let hoist uu = U.(uu >>= fun u -> mid (OK u))
1089 let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
1091 let throw e = U.mid (Error e)
1092 let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
1094 module Z(U : MONADZERO) : sig
1095 include MONADZEROT with type 'a result = 'a U.result and type 'a ut := 'a U.t
1096 include EXTRA with type 'a t := 'a t
1098 include Make.MonadFromTUZ(struct
1100 type 'a t = 'a error U.t
1101 type 'a result = 'a U.result
1102 (* we recover from error by using U's mzero; but this discards the error msg *)
1103 let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> mzero) in U.run uu
1104 let hoist uu = U.(uu >>= fun u -> mid (OK u))
1105 let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
1107 let throw e = U.mid (Error e)
1108 let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
1112 (* predefine some common instances *)
1114 module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = s1 ^ "\n" ^ s2 end)
1116 module Writer2 = struct
1117 include Writer(struct
1118 type log = string list
1120 let append s1 s2 = List.append s2 s1
1122 (* FIXME these aren't inside M *)
1123 let tell_string s = M.tell [s]
1124 let tell entries = M.tell (List.rev entries)
1125 let run xx = let (x,w) = M.run xx in (x, List.rev w)
1128 module Failure = Error(struct type err = string exception Exc = Failure end)
1132 module Option = Monad.Option
1133 module List = Monad.List