code/monad.ml

   1 (* This version from 1 April 2015 *)
   2
   3 module Monad = struct
   4
   5   module type MAPPABLE = sig
   6     type 'a t
   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 (). *)
   9   end
  10
  11   module type APPLICATIVE = sig
  12     include MAPPABLE
  13     val mid : 'a -> 'a t
  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
  18   end
  19
  20   module type MONAD = sig
  21     include APPLICATIVE
  22     type 'a result
  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
  33   end
  34
  35   module type MONADT = sig
  36     type 'a ut
  37     include MONAD
  38     val hoist : 'a ut -> 'a t
  39   end
  40
  41   module type ZERO = sig
  42     type 'a t
  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. *)
  44     val mzero : 'a t
  45     val guard : bool -> unit t
  46   end
  47
  48   module type MONADZERO = sig
  49     include MONAD
  50     include ZERO with type 'a t := 'a t
  51   end
  52
  53   module type MONADZEROT = sig
  54     include MONADT
  55     include ZERO with type 'a t := 'a t
  56   end
  57
  58   module type MAPPABLE2 = sig
  59     type ('a,'d) t
  60     val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
  61   end
  62
  63   module type APPLICATIVE2 = sig
  64     include MAPPABLE2
  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
  70   end
  71
  72   module type MONAD2 = sig
  73     include APPLICATIVE2
  74     type ('a,'d) result
  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
  85   end
  86
  87   module type MONAD2T = sig
  88     include MONAD2
  89     type ('a,'d) ut
  90     val hoist : ('a,'d) ut -> ('a,'d) t
  91   end
  92
  93   module type MONADZERO2 = sig
  94     include MONAD2
  95     val mzero : ('a,'d) t
  96     val guard : bool -> (unit,'d) t
  97   end
  98
  99   module type MONADZERO2T = sig
 100     include MONADZERO2
 101     type ('a,'d) ut
 102     val hoist : ('a,'d) ut -> ('a,'d) t
 103   end
 104
 105   module Make = struct
 106
 107     module type MAP2 = sig
 108       type 'a t
 109       val mid : 'a -> 'a t
 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]
 113     end
 114
 115     module type MAPPLY = sig
 116       type 'a t
 117       val mid : 'a -> 'a t
 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]
 121     end
 122
 123     module type BIND = sig
 124       type 'a t
 125       type 'a result
 126       val run : 'a t -> 'a result
 127       val mid : 'a -> 'a t
 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]
 132     end
 133
 134     module type COMP = sig
 135       type 'a t
 136       type 'a result
 137       val run : 'a t -> 'a result
 138       val mid : 'a -> 'a t
 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]
 143     end
 144
 145     module type JOIN = sig
 146       type 'a t
 147       type 'a result
 148       val run : 'a t -> 'a result
 149       val mid : 'a -> 'a t
 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]
 154     end
 155
 156     module type TRANS = sig
 157       module U : MONAD
 158       type 'a t
 159       type 'a result
 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
 164     end
 165
 166     module type TRANSUZ = sig
 167       module U : MONADZERO
 168       type 'a t
 169       type 'a result
 170       val run : 'a t -> 'a result
 171       val hoist : 'a U.t -> 'a t
 172       val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
 173     end
 174
 175     module type TRANSZ = sig
 176       module U : MONAD
 177       type 'a t
 178       type 'a result
 179       val run : 'a t -> 'a result
 180       val hoist : 'a U.t -> 'a t
 181       val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
 182       val mzero : 'a t
 183     end
 184
 185     module ApplicativeFromBind(B : BIND) : APPLICATIVE with type 'a t = 'a B.t = struct
 186       type 'a t = 'a B.t
 187       let mid = B.mid
 188       let (>>=) = B.(>>=)
 189       let map = match B.map with
 190       | `Custom map -> map
 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
 200     end
 201
 202     module ApplicativeFromMap2(B : MAP2) : APPLICATIVE with type 'a t = 'a B.t = struct
 203       type 'a t = 'a B.t
 204       let mid = B.mid
 205       let map2 = B.map2
 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
 210       | `Custom map -> map
 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
 214     end
 215
 216     module ApplicativeFromApply(B : MAPPLY) : APPLICATIVE with type 'a t = 'a B.t = struct
 217       type 'a t = 'a B.t
 218       let mid = B.mid
 219       let mapply = B.mapply
 220       let map = match B.map with
 221       | `Custom map -> map
 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
 228     end
 229
 230     module MonadFromBind(B : BIND) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
 231       let (>>=) = B.(>>=)
 232       include ApplicativeFromBind(B)
 233       type 'a result = 'a B.result
 234       let run = B.run
 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 [] *)
 240       (*
 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
 244          seq xxs =
 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 []
 248       *)
 249       let seq =
 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
 255         | [] -> mid ()
 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
 259     end
 260
 261     module MonadFromComp(B : COMP) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
 262       let (>=>) = B.(>=>)
 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
 267       let run = B.run
 268       let join xxx = xxx >>= ident
 269       let ignore xx = map (fun _ -> ()) xx
 270       let seq =
 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
 276         | [] -> mid ()
 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
 280     end
 281
 282     module MonadFromJoin(B : JOIN) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
 283       let join = B.join
 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
 287       let run = B.run
 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
 291       let seq =
 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
 297         | [] -> mid ()
 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
 301     end
 302
 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
 305         include B
 306         let mid x = hoist U.(mid x)
 307         let map = `Generate let map2 = `Generate let mapply = `Generate
 308       end)
 309       let hoist = B.hoist
 310     end
 311
 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
 315         include B
 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
 319       end)
 320       let hoist = B.hoist
 321       let guard res = if res then mid () else mzero
 322     end
 323
 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
 326         include B
 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
 330       end)
 331       let hoist = B.hoist
 332       let mzero = B.mzero
 333       let guard res = if res then mid () else mzero
 334     end
 335
 336     module type BIND2 = sig
 337       type ('a,'d) t
 338       type ('a,'d) result
 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]
 345     end
 346
 347     module type COMP2 = sig
 348       type ('a,'d) t
 349       type ('a,'d) result
 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]
 356     end
 357
 358     module type JOIN2 = sig
 359       type ('a,'d) t
 360       type ('a,'d) result
 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]
 367     end
 368
 369     module type TRANS2 = sig
 370       module U : MONAD2
 371       type ('a,'d) t
 372       type ('a,'d) result
 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
 376     end
 377
 378     module type TRANSUZ2 = sig
 379       module U : MONADZERO2
 380       type ('a,'d) t
 381       type ('a,'d) result
 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
 385     end
 386
 387     module type TRANSZ2 = sig
 388       module U : MONAD2
 389       type ('a,'d) t
 390       type ('a,'d) result
 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
 395     end
 396
 397     module type MAP22 = sig
 398       type ('a,'d) t
 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]
 403     end
 404
 405     module type MAPPLY2 = sig
 406       type ('a,'d) t
 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]
 411     end
 412
 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
 415       let mid = B.mid
 416       let (>>=) = B.(>>=)
 417       let map = match B.map with
 418       | `Custom map -> map
 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
 428     end
 429
 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
 432       let mid = B.mid
 433       let map2 = B.map2
 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
 438       | `Custom map -> map
 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
 442     end
 443
 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
 446       let mid = B.mid
 447       let mapply = B.mapply
 448       let map = match B.map with
 449       | `Custom map -> map
 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
 456     end
 457
 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
 459       let (>>=) = B.(>>=)
 460       include Applicative2FromBind(B)
 461       type ('a,'d) result = ('a,'d) B.result
 462       let run = B.run
 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
 467       let seq =
 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
 473         | [] -> mid ()
 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
 477     end
 478
 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
 480       let (>=>) = B.(>=>)
 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
 485       let run = B.run
 486       let join xxx = xxx >>= ident
 487       let ignore xx = map (fun _ -> ()) xx
 488       let seq =
 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
 494         | [] -> mid ()
 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
 498     end
 499
 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
 501       let join = B.join
 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
 505       let run = B.run
 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
 509       let seq =
 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
 515         | [] -> mid ()
 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
 519     end
 520
 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
 523         include B
 524         let mid x = hoist U.(mid x)
 525         let map = `Generate let map2 = `Generate let mapply = `Generate
 526       end)
 527       let hoist = B.hoist
 528     end
 529
 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
 532         include B
 533         let mid x = hoist U.(mid x)
 534         let map = `Generate let map2 = `Generate let mapply = `Generate
 535       end)
 536       let hoist = B.hoist
 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
 539     end
 540
 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
 543         include B
 544         let mid x = hoist U.(mid x)
 545         let map = `Generate let map2 = `Generate let mapply = `Generate
 546       end)
 547       let hoist = B.hoist
 548       let mzero = B.mzero
 549       let guard res = if res then mid () else mzero
 550     end
 551
 552   end (* Make *)
 553
 554
 555   module type OPTION = sig
 556     include MONADZERO with type 'a result = 'a option
 557     val test : ('a option -> bool) -> 'a t -> 'a t
 558   end
 559
 560   module type OPTIONT = sig
 561     type 'a uresult
 562     include MONADT with type 'a result = 'a option uresult
 563     val test : ('a option ut -> bool) -> 'a t -> 'a t
 564   end
 565
 566   module Option = struct
 567     include Juli8.Option
 568     module type EXTRA = sig
 569       type 'a t
 570       val test : ('a option (* U.t *) -> bool) -> 'a t -> 'a t
 571     end
 572     module type EXTRA2 = sig
 573       type ('a,'d) t
 574       val test : ('a option -> bool) -> ('a,'d) t -> ('a,'d) t
 575     end
 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
 581         let mid = some
 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
 584       end)
 585       let mzero = 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
 588     end (* Option.M *)
 589     module M2 : sig
 590       include MONADZERO2 with type ('a,'d) result = 'a option
 591       include EXTRA2 with type ('a,'d) t := ('a,'d) t
 592     end = struct
 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
 597         let mid = some
 598         let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
 599       end)
 600       let mzero = 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
 603     end (* Option.M2 *)
 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
 606         module U = U
 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)
 612       end)
 613       let test p xx = if p xx then xx else U.mid None
 614     end (* Option.T *)
 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
 619     end = struct
 620       include Make.Monad2FromTZ(struct
 621         module U = U
 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)
 627       end)
 628       let test p xx = if p xx then xx else U.mid None
 629     end (* Option.T2 *)
 630   end (* Option *)
 631
 632
 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
 638   end
 639
 640   module type LISTT = sig
 641     type 'a uresult
 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
 646     (*
 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
 651     *)
 652     val distribute : ('a -> 'b ut) -> 'a list -> 'b t
 653   end
 654
 655   module List = struct
 656     include Juli8.List
 657     module type EXTRA2 = sig
 658       type ('a,'d) t
 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
 662     end
 663     module M : LIST = struct
 664       include Make.MonadFromBind(struct
 665         type 'a t = 'a list
 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
 668         let mid = singleton
 669         let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
 670       end)
 671       let mzero = []
 672       let guard res : unit t = if res then [()] else []
 673       (* (++) has tighter precedence than (>>=) *)
 674       let (++) = append
 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 []
 677     end (* List.M *)
 678     module M2 : sig
 679       include MONADZERO2 with type ('a,'d) result = 'a list
 680       include EXTRA2 with type ('a,'d) t := ('a,'d) t
 681     end = struct
 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
 686         let mid = singleton
 687         let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
 688       end)
 689       let mzero = []
 690       let guard res : (unit,'d) t = if res then [()] else []
 691       let (++) = append
 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 []
 694     end (* List.M2 *)
 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
 698         module U = U
 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 [])
 704       end)
 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 []
 708     end (* List.T *)
 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
 714     end = struct
 715       let distribute k xs = U.seq (List.map k xs)
 716       include Make.Monad2FromTZ(struct
 717         module U = U
 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 [])
 723       end)
 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 []
 727     end (* List.T2 *)
 728   end (* List *)
 729
 730
 731   (* LTree, unit centers, has natural ++ *)
 732   (* ITree, unit leaves, has natural mzero *)
 733
 734   module type TREE = sig
 735     type 'a tree
 736     include MONAD with type 'a result = 'a tree
 737     val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
 738   end
 739
 740   module type TREET = sig
 741     type 'a tree
 742     type 'a uresult
 743     include MONADT with type 'a result = 'a tree uresult
 744     val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
 745     (*
 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
 750     *)
 751     val distribute : ('a -> 'b ut) -> 'a tree -> 'b t
 752   end
 753
 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)
 757     let leaf x = Leaf x
 758     let traverse ((++) : 'b -> 'b -> 'b) (k : 'a -> 'b) (xt : 'a tree) : 'b =
 759       let rec aux = function
 760       | Leaf x -> k x
 761       | Branch(l, r) -> (* recursive application of k may delete a branch? *) aux l ++ aux r in
 762       aux xt
 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
 767       aux xt
 768     module M : TREE with type 'a tree := 'a tree = struct
 769       include Make.MonadFromBind(struct
 770         type 'a t = 'a tree
 771         type 'a result = 'a t let run xx = xx
 772         let map = `Custom map let map2 = `Generate let mapply = `Generate
 773         let mid = leaf
 774         let (>>=) xx k = traverse branch k xx
 775       end)
 776       let (++) xx yy = Branch(xx, yy)
 777     end (* Tree.M *)
 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
 782         module U = U
 783         type 'a t = 'a tree U.t
 784         type 'a result = 'a tree U.result let run xx = U.run xx
 785         let hoist = hoist
 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)))
 788       end)
 789       let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
 790     end (* Tree.T *)
 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
 794     end = struct
 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
 798         module U = U
 799         type 'a t = 'a tree U.t
 800         type 'a result = 'a tree U.result let run xx = U.run xx
 801         let hoist = hoist
 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)))
 804       end)
 805       let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
 806     end (* Tree.Z *)
 807   end (* Tree *)
 808
 809
 810   module Identity = struct
 811     module M : sig
 812       include MONAD with type 'a result = 'a
 813     end = struct
 814       include Make.MonadFromComp(struct
 815         type 'a t = 'a
 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)
 818         let mid = ident
 819         let (>=>) j k = fun x -> k (j x)
 820       end)
 821     end
 822   end
 823
 824
 825   module type READER = sig
 826     type env
 827     include MONAD with type 'a result = env -> 'a
 828     val ask : env t
 829     val asks : (env -> 'a) -> 'a t
 830     val shift : (env -> env) -> 'a t -> 'a t
 831   end
 832
 833   module type READERT = sig
 834     type env
 835     type 'a uresult
 836     include MONADT with type 'a result = env -> 'a uresult
 837     val ask : env t
 838     val asks : (env -> 'a) -> 'a t
 839     val shift : (env -> env) -> 'a t -> 'a t
 840   end
 841
 842   (* must be parameterized on `struct type env = ... end` *)
 843   module Reader(E : sig type env end) = struct
 844     type env = E.env
 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
 852       end)
 853       let ask = fun e -> 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)
 856     end (* Reader.M *)
 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
 859         module U = U
 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)
 864       end)
 865       let ask = U.mid
 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)
 868     end (* Reader.T *)
 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
 872     end = struct
 873       include Make.MonadFromTUZ(struct
 874         module U = U
 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)
 879       end)
 880       let ask = U.mid
 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)
 883     end (* Reader.Z *)
 884   end (* Reader *)
 885
 886
 887   module type STATE = sig
 888     type store
 889     include MONAD with type 'a result = store -> 'a * store
 890     val get : store t
 891     val gets : (store -> 'a) -> 'a t
 892     val put : store -> unit t
 893     val modify : (store -> store) -> unit t
 894   end
 895
 896   module type STATET = sig
 897     type store
 898     type 'a uresult
 899     include MONADT with type 'a result = store -> ('a * store) uresult
 900     val get : store t
 901     val gets : (store -> 'a) -> 'a t
 902     val put : store -> unit t
 903     val modify : (store -> store) -> unit t
 904   end
 905
 906   (* must be parameterized on `struct type store = ... end` *)
 907   module State(S : sig type store end) = struct
 908     type store = S.store
 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'
 916       end)
 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
 922     end (* State.M *)
 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
 925         module U = U
 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')
 930       end)
 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)
 935     end (* State.T *)
 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
 939     end = struct
 940       include Make.MonadFromTUZ(struct
 941         module U = U
 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')
 946       end)
 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)
 951     end (* State.Z *)
 952   end (* State *)
 953
 954
 955   module type REF = sig
 956     type ref
 957     type value
 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
 962   end
 963
 964   module type REFT = sig
 965     type ref
 966     type value
 967     type 'a uresult
 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
 972   end
 973
 974   (* State with a different interface; must be parameterized on `struct type value = ... end` *)
 975   module Ref(V : sig type value end) = struct
 976     type ref = int
 977     type value = V.value
 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'
 991       end)
 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 *)
 995     end (* Ref.M *)
 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
 998         module U = U
 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')
1003       end)
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)
1007     end (* Ref.T *)
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
1011     end = struct
1012       include Make.MonadFromTUZ(struct
1013         module U = U
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')
1018       end)
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)
1022     end (* Ref.Z *)
1023   end (* Ref *)
1024
1025
1026   module type WRITER = sig
1027     type log
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
1034   end
1035
1036   module type WRITERT = sig
1037     type log
1038     type 'a uresult
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
1045   end
1046
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
1049     type log = W.log
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')
1057       end)
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) *)
1063     end (* Writer.M *)
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
1066         module U = U
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'))
1071       end)
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))
1077     end (* Writer.T *)
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
1081     end = struct
1082       include Make.MonadFromTUZ(struct
1083         module U = U
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'))
1088       end)
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))
1094     end (* Writer.Z *)
1095   end (* Writer *)
1096
1097
1098   module type ERROR = sig
1099     type msg
1100     type 'a error
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
1104   end
1105
1106   module type ERRORT = sig
1107     type msg
1108     type 'a error
1109     type 'a uresult
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
1113   end
1114
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
1117     type msg = E.msg
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 *)
1124         let run xx = xx
1125         let map = `Generate let map2 = `Generate let mapply = `Generate
1126         let mid x = OK x
1127         let (>>=) xx k = match xx with OK x -> k x | Error e -> Error e
1128       end)
1129       let throw e = Error e
1130       let catch xx handler = match xx with OK _ -> xx | Error e -> handler e
1131     end (* Error.M *)
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
1134         module U = U
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))
1141       end)
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)
1144     end (* Error.T *)
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
1148     end = struct
1149       include Make.MonadFromTUZ(struct
1150         module U = U
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))
1157       end)
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)
1160     end (* Error.Z *)
1161   end (* Error *)
1162
1163
1164   (* predefine some common instances *)
1165
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)
1167
1168   module Writer2 = struct
1169     include Writer(struct
1170       type log = string list
1171       let empty = []
1172       let append s1 s2 = List.append s2 s1
1173     end)
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)
1178   end
1179
1180   module Failure = Error(struct type msg = string exception Exc = Failure end)
1181
1182 end (* Monad *)
1183
1184 module Option = Monad.Option
1185 module List = Monad.List
1186