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     include MONAD
  37     type 'a ut
  38     val hoist : 'a ut -> 'a t
  39   end
  40
  41   module type MONADZERO = sig
  42     include MONAD
  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 MONADZEROT = sig
  49     include MONADZERO
  50     type 'a ut
  51     val hoist : 'a ut -> 'a t
  52   end
  53
  54   module type MAPPABLE2 = sig
  55     type ('a,'d) t
  56     val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
  57   end
  58
  59   module type APPLICATIVE2 = sig
  60     include MAPPABLE2
  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
  66   end
  67
  68   module type MONAD2 = sig
  69     include APPLICATIVE2
  70     type ('a,'d) result
  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
  81   end
  82
  83   module type MONAD2T = sig
  84     include MONAD2
  85     type ('a,'d) ut
  86     val hoist : ('a,'d) ut -> ('a,'d) t
  87   end
  88
  89   module type MONADZERO2 = sig
  90     include MONAD2
  91     val mzero : ('a,'d) t
  92     val guard : bool -> (unit,'d) t
  93   end
  94
  95   module type MONADZERO2T = sig
  96     include MONADZERO2
  97     type ('a,'d) ut
  98     val hoist : ('a,'d) ut -> ('a,'d) t
  99   end
 100
 101   module Make = struct
 102
 103     module type MAP2 = sig
 104       type 'a t
 105       val mid : 'a -> 'a t
 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]
 109     end
 110
 111     module type MAPPLY = sig
 112       type 'a t
 113       val mid : 'a -> 'a t
 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]
 117     end
 118
 119     module type BIND = sig
 120       type 'a t
 121       type 'a result
 122       val run : 'a t -> 'a result
 123       val mid : 'a -> 'a t
 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]
 128     end
 129
 130     module type COMP = sig
 131       type 'a t
 132       type 'a result
 133       val run : 'a t -> 'a result
 134       val mid : 'a -> 'a t
 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]
 139     end
 140
 141     module type JOIN = sig
 142       type 'a t
 143       type 'a result
 144       val run : 'a t -> 'a result
 145       val mid : 'a -> 'a t
 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]
 150     end
 151
 152     module type TRANS = sig
 153       module U : MONAD
 154       type 'a t
 155       type 'a result
 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
 160     end
 161
 162     module type TRANSUZ = sig
 163       module U : MONADZERO
 164       type 'a t
 165       type 'a result
 166       val run : 'a t -> 'a result
 167       val hoist : 'a U.t -> 'a t
 168       val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
 169     end
 170
 171     module type TRANSZ = sig
 172       module U : MONAD
 173       type 'a t
 174       type 'a result
 175       val run : 'a t -> 'a result
 176       val hoist : 'a U.t -> 'a t
 177       val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
 178       val mzero : 'a t
 179     end
 180
 181     module ApplicativeFromBind(B : BIND) : APPLICATIVE with type 'a t = 'a B.t = struct
 182       type 'a t = 'a B.t
 183       let mid = B.mid
 184       let (>>=) = B.(>>=)
 185       let map = match B.map with
 186       | `Custom map -> map
 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
 196     end
 197
 198     module ApplicativeFromMap2(B : MAP2) : APPLICATIVE with type 'a t = 'a B.t = struct
 199       type 'a t = 'a B.t
 200       let mid = B.mid
 201       let map2 = B.map2
 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
 206       | `Custom map -> map
 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
 210     end
 211
 212     module ApplicativeFromApply(B : MAPPLY) : APPLICATIVE with type 'a t = 'a B.t = struct
 213       type 'a t = 'a B.t
 214       let mid = B.mid
 215       let mapply = B.mapply
 216       let map = match B.map with
 217       | `Custom map -> map
 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
 224     end
 225
 226     module MonadFromBind(B : BIND) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
 227       let (>>=) = B.(>>=)
 228       include ApplicativeFromBind(B)
 229       type 'a result = 'a B.result
 230       let run = B.run
 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 [] *)
 236       (*
 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
 240          seq xxs =
 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 []
 244       *)
 245       let seq =
 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
 251         | [] -> mid ()
 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
 255     end
 256
 257     module MonadFromComp(B : COMP) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
 258       let (>=>) = B.(>=>)
 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
 263       let run = B.run
 264       let join xxx = xxx >>= ident
 265       let ignore xx = map (fun _ -> ()) xx
 266       let seq =
 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
 272         | [] -> mid ()
 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
 276     end
 277
 278     module MonadFromJoin(B : JOIN) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
 279       let join = B.join
 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
 283       let run = B.run
 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
 287       let seq =
 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
 293         | [] -> mid ()
 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
 297     end
 298
 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
 301         include B
 302         let mid x = hoist U.(mid x)
 303         let map = `Generate let map2 = `Generate let mapply = `Generate
 304       end)
 305       let hoist = B.hoist
 306     end
 307
 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
 311         include B
 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
 315       end)
 316       let hoist = B.hoist
 317       let guard res = if res then mid () else mzero
 318     end
 319
 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
 322         include B
 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
 326       end)
 327       let hoist = B.hoist
 328       let mzero = B.mzero
 329       let guard res = if res then mid () else mzero
 330     end
 331
 332     module type BIND2 = sig
 333       type ('a,'d) t
 334       type ('a,'d) result
 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]
 341     end
 342
 343     module type COMP2 = sig
 344       type ('a,'d) t
 345       type ('a,'d) result
 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]
 352     end
 353
 354     module type JOIN2 = sig
 355       type ('a,'d) t
 356       type ('a,'d) result
 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]
 363     end
 364
 365     module type TRANS2 = sig
 366       module U : MONAD2
 367       type ('a,'d) t
 368       type ('a,'d) result
 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
 372     end
 373
 374     module type TRANSUZ2 = sig
 375       module U : MONADZERO2
 376       type ('a,'d) t
 377       type ('a,'d) result
 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
 381     end
 382
 383     module type TRANSZ2 = sig
 384       module U : MONAD2
 385       type ('a,'d) t
 386       type ('a,'d) result
 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
 391     end
 392
 393     module type MAP22 = sig
 394       type ('a,'d) t
 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]
 399     end
 400
 401     module type MAPPLY2 = sig
 402       type ('a,'d) t
 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]
 407     end
 408
 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
 411       let mid = B.mid
 412       let (>>=) = B.(>>=)
 413       let map = match B.map with
 414       | `Custom map -> map
 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
 424     end
 425
 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
 428       let mid = B.mid
 429       let map2 = B.map2
 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
 434       | `Custom map -> map
 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
 438     end
 439
 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
 442       let mid = B.mid
 443       let mapply = B.mapply
 444       let map = match B.map with
 445       | `Custom map -> map
 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
 452     end
 453
 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
 455       let (>>=) = B.(>>=)
 456       include Applicative2FromBind(B)
 457       type ('a,'d) result = ('a,'d) B.result
 458       let run = B.run
 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
 463       let seq =
 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
 469         | [] -> mid ()
 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
 473     end
 474
 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
 476       let (>=>) = B.(>=>)
 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
 481       let run = B.run
 482       let join xxx = xxx >>= ident
 483       let ignore xx = map (fun _ -> ()) xx
 484       let seq =
 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
 490         | [] -> mid ()
 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
 494     end
 495
 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
 497       let join = B.join
 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
 501       let run = B.run
 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
 505       let seq =
 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
 511         | [] -> mid ()
 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
 515     end
 516
 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
 519         include B
 520         let mid x = hoist U.(mid x)
 521         let map = `Generate let map2 = `Generate let mapply = `Generate
 522       end)
 523       let hoist = B.hoist
 524     end
 525
 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
 528         include B
 529         let mid x = hoist U.(mid x)
 530         let map = `Generate let map2 = `Generate let mapply = `Generate
 531       end)
 532       let hoist = B.hoist
 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
 535     end
 536
 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
 539         include B
 540         let mid x = hoist U.(mid x)
 541         let map = `Generate let map2 = `Generate let mapply = `Generate
 542       end)
 543       let hoist = B.hoist
 544       let mzero = B.mzero
 545       let guard res = if res then mid () else mzero
 546     end
 547
 548   end (* Make *)
 549
 550
 551
 552   module Option = struct
 553     include Juli8.Option
 554     module type EXTRA = sig
 555       type 'a t
 556       val test : ('a option (* U.t *) -> bool) -> 'a t -> 'a t
 557     end
 558     module type EXTRA2 = sig
 559       type ('a,'d) t
 560       val test : ('a option -> bool) -> ('a,'d) t -> ('a,'d) t
 561     end
 562     module M : sig
 563       include MONADZERO with type 'a result = 'a option
 564       include EXTRA with type 'a t := 'a t
 565     end = struct
 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
 570         let mid = some
 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
 573       end)
 574       let mzero = 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
 577     end (* Option.M *)
 578     module M2 : sig
 579       include MONADZERO2 with type ('a,'d) result = 'a option
 580       include EXTRA2 with type ('a,'d) t := ('a,'d) t
 581     end = struct
 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
 586         let mid = some
 587         let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
 588       end)
 589       let mzero = 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
 592     end (* Option.M2 *)
 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
 597     end = struct
 598       include Make.MonadFromTZ(struct
 599         module U = U
 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)
 605       end)
 606       let test p xx = if p xx then xx else U.mid None
 607     end (* Option.T *)
 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
 612     end = struct
 613       include Make.Monad2FromTZ(struct
 614         module U = U
 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)
 620       end)
 621       let test p xx = if p xx then xx else U.mid None
 622     end (* Option.T2 *)
 623   end (* Option *)
 624
 625   module List = struct
 626     include Juli8.List
 627     module type EXTRA = sig
 628       type 'a t
 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
 632     end
 633     module type EXTRA2 = sig
 634       type ('a,'d) t
 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
 638     end
 639     module M : sig
 640       include MONADZERO with type 'a result = 'a list
 641       include EXTRA with type 'a t := 'a t
 642     end = struct
 643       include Make.MonadFromBind(struct
 644         type 'a t = 'a list
 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
 647         let mid = singleton
 648         let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
 649       end)
 650       let mzero = []
 651       let guard res : unit t = if res then [()] else []
 652       (* (++) has tighter precedence than (>>=) *)
 653       let (++) = append
 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 []
 656     end (* List.M *)
 657     module M2 : sig
 658       include MONADZERO2 with type ('a,'d) result = 'a list
 659       include EXTRA2 with type ('a,'d) t := ('a,'d) t
 660     end = struct
 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
 665         let mid = singleton
 666         let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
 667       end)
 668       let mzero = []
 669       let guard res : (unit,'d) t = if res then [()] else []
 670       let (++) = append
 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 []
 673     end (* List.M2 *)
 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
 678       (*
 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
 683       *)
 684       val distribute : ('a -> 'b U.t) -> 'a list -> 'b t
 685     end = struct
 686       let distribute k xs = U.seq (List.map k xs)
 687       include Make.MonadFromTZ(struct
 688         module U = U
 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 [])
 694       end)
 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 []
 698     end (* List.T *)
 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
 704     end = struct
 705       let distribute k xs = U.seq (List.map k xs)
 706       include Make.Monad2FromTZ(struct
 707         module U = U
 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 [])
 713       end)
 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 []
 717     end (* List.T2 *)
 718   end (* List *)
 719
 720
 721   (* LTree, unit centers, has natural ++ *)
 722   (* ITree, unit leaves, has natural mzero *)
 723
 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)
 727     let leaf x = Leaf x
 728     let traverse ((++) : 'b -> 'b -> 'b) (k : 'a -> 'b) (xt : 'a tree) : 'b =
 729       let rec aux = function
 730       | Leaf x -> k x
 731       | Branch(l, r) -> (* recursive application of k may delete a branch? *) aux l ++ aux r in
 732       aux xt
 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
 737       aux xt
 738     module type EXTRA = sig
 739       type 'a t
 740       val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
 741     end
 742     module M : sig
 743       include MONAD with type 'a result = 'a tree
 744       include EXTRA with type 'a t := 'a t
 745     end = struct
 746       include Make.MonadFromBind(struct
 747         type 'a t = 'a tree
 748         type 'a result = 'a t let run xx = xx
 749         let map = `Custom map let map2 = `Generate let mapply = `Generate
 750         let mid = leaf
 751         let (>>=) xx k = traverse branch k xx
 752       end)
 753       let (++) xx yy = Branch(xx, yy)
 754     end (* Tree.M *)
 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
 758       (*
 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
 763       *)
 764       val distribute : ('a -> 'b U.t) -> 'a tree -> 'b t
 765     end = struct
 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
 769         module U = U
 770         type 'a t = 'a tree U.t
 771         type 'a result = 'a tree U.result let run xx = U.run xx
 772         let hoist = hoist
 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)))
 775       end)
 776       let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
 777     end (* Tree.T *)
 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
 782     end = struct
 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
 786         module U = U
 787         type 'a t = 'a tree U.t
 788         type 'a result = 'a tree U.result let run xx = U.run xx
 789         let hoist = hoist
 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)))
 792       end)
 793       let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
 794     end (* Tree.Z *)
 795   end (* Tree *)
 796
 797
 798   module Identity = struct
 799     module M : sig
 800       include MONAD with type 'a result = 'a
 801     end = struct
 802       include Make.MonadFromComp(struct
 803         type 'a t = 'a
 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)
 806         let mid = ident
 807         let (>=>) j k = fun x -> k (j x)
 808       end)
 809     end
 810   end
 811
 812   (* must be parameterized on `struct type env = ... end` *)
 813   module Reader(E : sig type env end) = struct
 814     type env = E.env
 815     module type EXTRA = sig
 816       type 'a t
 817       val ask : env t
 818       val asks : (env -> 'a) -> 'a t
 819       val shift : (env -> env) -> 'a t -> 'a t
 820     end
 821     module M : sig
 822       include MONAD with type 'a result = env -> 'a
 823       include EXTRA with type 'a t := 'a t
 824     end = struct
 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
 831       end)
 832       let ask = fun e -> 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)
 835     end (* Reader.M *)
 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
 839     end = struct
 840       include Make.MonadFromT(struct
 841         module U = U
 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)
 846       end)
 847       let ask = U.mid
 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)
 850     end (* Reader.T *)
 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
 854     end = struct
 855       include Make.MonadFromTUZ(struct
 856         module U = U
 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)
 861       end)
 862       let ask = U.mid
 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)
 865     end (* Reader.Z *)
 866   end (* Reader *)
 867
 868   (* must be parameterized on `struct type store = ... end` *)
 869   module State(S : sig type store end) = struct
 870     type store = S.store
 871     module type EXTRA = sig
 872       type 'a t
 873       val get : store t
 874       val gets : (store -> 'a) -> 'a t
 875       val put : store -> unit t
 876       val modify : (store -> store) -> unit t
 877     end
 878     module M : sig
 879       include MONAD with type 'a result = store -> 'a * store
 880       include EXTRA with type 'a t := 'a t
 881     end = struct
 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'
 888       end)
 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
 894     end (* State.M *)
 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
 898     end = struct
 899       include Make.MonadFromT(struct
 900         module U = U
 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')
 905       end)
 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)
 910     end (* State.T *)
 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
 914     end = struct
 915       include Make.MonadFromTUZ(struct
 916         module U = U
 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')
 921       end)
 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)
 926     end (* State.Z *)
 927   end (* State *)
 928
 929   (* State with a different interface; must be parameterized on `struct type value = ... end` *)
 930   module Ref(V : sig type value end) = struct
 931     type ref = int
 932     type value = V.value
 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
 940       type 'a t
 941       val newref : value -> ref t
 942       val deref : ref -> value t
 943       val change : ref -> value -> unit t
 944     end
 945     module M : sig
 946       include MONAD with type 'a result = 'a
 947       include EXTRA with type 'a t := 'a t
 948     end = struct
 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'
 955       end)
 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 *)
 959     end (* Ref.M *)
 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
 963     end = struct
 964       include Make.MonadFromT(struct
 965         module U = U
 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')
 970       end)
 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)
 974     end (* Ref.T *)
 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
 978     end = struct
 979       include Make.MonadFromTUZ(struct
 980         module U = U
 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')
 985       end)
 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)
 989     end (* Ref.Z *)
 990   end (* Ref *)
 991
 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
 994     type log = W.log
 995     module type EXTRA = sig
 996       type 'a t
 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
1002     end
1003     module M : sig
1004       include MONAD with type 'a result = 'a * log
1005       include EXTRA with type 'a t := 'a t
1006     end = struct
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')
1013       end)
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) *)
1019     end (* Writer.M *)
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
1023     end = struct
1024       include Make.MonadFromT(struct
1025         module U = U
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'))
1030       end)
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))
1036     end (* Writer.T *)
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
1040     end = struct
1041       include Make.MonadFromTUZ(struct
1042         module U = U
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'))
1047       end)
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))
1053     end (* Writer.Z *)
1054   end (* Writer *)
1055
1056   (* must be parameterized on `struct type err = ... end` *)
1057   module Error(E : sig type err exception Exc of err end) = struct
1058     type err = E.err
1059     type 'a error = Error of err | OK of 'a
1060     module type EXTRA = sig
1061       type 'a t
1062       val throw : err -> 'a t
1063       val catch : 'a t -> (err -> 'a t) -> 'a t
1064     end
1065     module M : sig
1066       include MONAD with type 'a result = 'a error
1067       include EXTRA with type 'a t := 'a t
1068     end = struct
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
1073         let mid x = OK x
1074         let (>>=) xx k = match xx with OK x -> k x | Error e -> Error e
1075       end)
1076       let throw e = Error e
1077       let catch xx handler = match xx with OK _ -> xx | Error e -> handler e
1078     end (* Error.M *)
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
1082     end = struct
1083       include Make.MonadFromT(struct
1084         module U = U
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))
1090       end)
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)
1093     end (* Error.T *)
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
1097     end = struct
1098       include Make.MonadFromTUZ(struct
1099         module U = U
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))
1106       end)
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)
1109     end (* Error.Z *)
1110   end (* Error *)
1111
1112   (* predefine some common instances *)
1113
1114   module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = s1 ^ "\n" ^ s2 end)
1115
1116   module Writer2 = struct
1117     include Writer(struct
1118       type log = string list
1119       let empty = []
1120       let append s1 s2 = List.append s2 s1
1121     end)
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)
1126   end
1127
1128   module Failure = Error(struct type err = string exception Exc = Failure end)
1129
1130 end (* Monad *)
1131
1132 module Option = Monad.Option
1133 module List = Monad.List
1134