code/monads.ml

   1 (*
   2  * monads.ml
   3  *
   4  * Relies on features introduced in OCaml 3.12
   5  *
   6  * This library uses parameterized modules, see tree_monadize.ml for
   7  * more examples and explanation.
   8  *
   9  * Some comparisons with the Haskell monadic libraries, which we mostly follow:
  10  * In Haskell, the Reader 'a monadic type would be defined something like this:
  11  *     newtype Reader a = Reader { runReader :: env -> a }
  12  * (For simplicity, I'm suppressing the fact that Reader is also parameterized
  13  * on the type of env.)
  14  * This creates a type wrapper around `env -> a`, so that Haskell will
  15  * distinguish between values that have been specifically designated as
  16  * being of type `Reader a`, and common-garden values of type `env -> a`.
  17  * To lift an aribtrary expression E of type `env -> a` into an `Reader a`,
  18  * you do this:
  19  *     Reader { runReader = E }
  20  * or use any of the following equivalent shorthands:
  21  *     Reader (E)
  22  *     Reader $ E
  23  * To drop an expression R of type `Reader a` back into an `env -> a`, you do
  24  * one of these:
  25  *     runReader (R)
  26  *     runReader $ R
  27  * The `newtype` in the type declaration ensures that Haskell does this all
  28  * efficiently: though it regards E and R as type-distinct, their underlying
  29  * machine implementation is identical and doesn't need to be transformed when
  30  * lifting/dropping from one type to the other.
  31  *
  32  * Now, you _could_ also declare monads as record types in OCaml, too, _but_
  33  * doing so would introduce an extra level of machine representation, and
  34  * lifting/dropping from the one type to the other wouldn't be free like it is
  35  * in Haskell.
  36  *
  37  * This library encapsulates the monadic types in another way: by
  38  * making their implementations private. The interpreter won't let
  39  * let you freely interchange the `'a Reader_monad.m`s defined below
  40  * with `Reader_monad.env -> 'a`. The code in this library can see that
  41  * those are equivalent, but code outside the library can't. Instead, you'll
  42  * have to use operations like `run` to convert the abstract monadic types
  43  * to types whose internals you have free access to.
  44  *
  45  *)
  46
  47
  48 (* Some library functions used below. *)
  49 module Util = struct
  50   let fold_right = List.fold_right
  51   let map = List.map
  52   let append = List.append
  53   let reverse = List.rev
  54   let concat = List.concat
  55   let concat_map f lst = List.concat (List.map f lst)
  56   (* let zip = List.combine *)
  57   let unzip = List.split
  58   let zip_with = List.map2
  59   let replicate len fill =
  60     let rec loop n accu =
  61       if n == 0 then accu else loop (pred n) (fill :: accu)
  62     in loop len []
  63 end
  64
  65
  66
  67 (*
  68  * This module contains factories that extend a base set of
  69  * monadic definitions with a larger family of standard derived values.
  70  *)
  71
  72 module Monad = struct
  73   (*
  74    * Signature extenders:
  75    *   Make :: BASE -> S
  76    *     MakeCatch, MakeDistrib :: PLUSBASE -> PLUS
  77    *                                           which merges into S
  78    *                                           (P is merged sig)
  79    *   MakeT :: TRANS (with Wrapped : S or P) -> custom sig
  80    *
  81    *   Make2 :: BASE2 -> S2
  82    *     MakeCatch2, MakeDistrib2 :: PLUSBASE2 -> PLUS2 (P2 is merged sig)
  83    *   to wrap double-typed inner monads:
  84    *   MakeT2 :: TRANS2 (with Wrapped : S2 or P2) -> custom sig
  85    *
  86    *)
  87
  88
  89
  90   (* type of base definitions *)
  91   module type BASE = sig
  92     (* The only constraints we impose here on how the monadic type
  93      * is implemented is that it have a single type parameter 'a. *)
  94     type 'a m
  95     type 'a result
  96     type 'a result_exn
  97     val unit : 'a -> 'a m
  98     val bind : 'a m -> ('a -> 'b m) -> 'b m
  99     val run : 'a m -> 'a result
 100     (* run_exn tries to provide a more ground-level result, but may fail *)
 101     val run_exn : 'a m -> 'a result_exn
 102   end
 103   module type S = sig
 104     include BASE
 105     val (>>=) : 'a m -> ('a -> 'b m) -> 'b m
 106     val (>>) : 'a m -> 'b m -> 'b m
 107     val join : ('a m) m -> 'a m
 108     val apply : ('a -> 'b) m -> 'a m -> 'b m
 109     val lift : ('a -> 'b) -> 'a m -> 'b m
 110     val lift2 :  ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m
 111     val (>=>) : ('a -> 'b m) -> ('b -> 'c m) -> 'a -> 'c m
 112     val do_when :  bool -> unit m -> unit m
 113     val do_unless :  bool -> unit m -> unit m
 114     val forever : 'a m -> 'b m
 115     val sequence : 'a m list -> 'a list m
 116     val sequence_ : 'a m list -> unit m
 117   end
 118
 119   (* Standard, single-type-parameter monads. *)
 120   module Make(B : BASE) : S with type 'a m = 'a B.m and type 'a result = 'a B.result and type 'a result_exn = 'a B.result_exn = struct
 121     include B
 122     let (>>=) = bind
 123     let (>>) u v = u >>= fun _ -> v
 124     let lift f u = u >>= fun a -> unit (f a)
 125     (* lift is called listM, fmap, and <$> in Haskell *)
 126     let join uu = uu >>= fun u -> u
 127     (* u >>= f === join (lift f u) *)
 128     let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
 129     (* [f] <*> [x1,x2] = [f x1,f x2] *)
 130     (* let apply u v = u >>= fun f -> lift f v *)
 131     (* let apply = lift2 id *)
 132     let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
 133     (* let lift f u === apply (unit f) u *)
 134     (* let lift2 f u v = apply (lift f u) v *)
 135     let (>=>) f g = fun a -> f a >>= g
 136     let do_when test u = if test then u else unit ()
 137     let do_unless test u = if test then unit () else u
 138     let rec forever u = u >> forever u
 139     let sequence ms =
 140       let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
 141         Util.fold_right op ms (unit [])
 142     let sequence_ ms =
 143       Util.fold_right (>>) ms (unit ())
 144
 145     (* Haskell defines these other operations combining lists and monads.
 146      * We don't, but notice that M.mapM == ListT(M).distribute
 147      * There's also a parallel TreeT(M).distribute *)
 148     (*
 149     let mapM f alist = sequence (Util.map f alist)
 150     let mapM_ f alist = sequence_ (Util.map f alist)
 151     let rec filterM f lst = match lst with
 152       | [] -> unit []
 153       | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
 154     let forM alist f = mapM f alist
 155     let forM_ alist f = mapM_ f alist
 156     let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
 157     let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
 158     let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
 159     let rec foldM f z lst = match lst with
 160       | [] -> unit z
 161       | x::xs -> f z x >>= fun z' -> foldM f z' xs
 162     let foldM_ f z xs = foldM f z xs >> unit ()
 163     let replicateM n x = sequence (Util.replicate n x)
 164     let replicateM_ n x = sequence_ (Util.replicate n x)
 165     *)
 166   end
 167
 168   (* Single-type-parameter monads that also define `plus` and `zero`
 169    * operations. These obey the following laws:
 170    *     zero >>= f   ===  zero
 171    *     plus zero u  ===  u
 172    *     plus u zero  ===  u
 173    * Additionally, these monads will obey one of the following laws:
 174    *     (Catch)   plus (unit a) v  ===  unit a
 175    *     (Distrib) plus u v >>= f   ===  plus (u >>= f) (v >>= f)
 176    *)
 177   module type PLUSBASE = sig
 178     include BASE
 179     val zero : unit -> 'a m
 180     val plus : 'a m -> 'a m -> 'a m
 181   end
 182   module type PLUS = sig
 183     type 'a m
 184     val zero : unit -> 'a m
 185     val plus : 'a m -> 'a m -> 'a m
 186     val guard : bool -> unit m
 187     val sum : 'a m list -> 'a m
 188   end
 189   (* MakeCatch and MakeDistrib have the same implementation; we just declare
 190    * them twice to document which laws the client code is promising to honor. *)
 191   module MakeCatch(B : PLUSBASE) : PLUS with type 'a m = 'a B.m = struct
 192     type 'a m = 'a B.m
 193     let zero = B.zero
 194     let plus = B.plus
 195     let guard test = if test then B.unit () else zero ()
 196     let sum ms = Util.fold_right plus ms (zero ())
 197   end
 198   module MakeDistrib = MakeCatch
 199
 200   (* Signatures for MonadT *)
 201   (* sig for Wrapped that include S and PLUS *)
 202   module type P = sig
 203     include S
 204     include PLUS with type 'a m := 'a m
 205   end
 206   module type TRANS = sig
 207     module Wrapped : S
 208     type 'a m
 209     type 'a result
 210     type 'a result_exn
 211     val bind : 'a m -> ('a -> 'b m) -> 'b m
 212     val run : 'a m -> 'a result
 213     val run_exn : 'a m -> 'a result_exn
 214     val elevate : 'a Wrapped.m -> 'a m
 215     (* lift/elevate laws:
 216      *     elevate (W.unit a) == unit a
 217      *     elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
 218      *)
 219   end
 220   module MakeT(T : TRANS) = struct
 221     include Make(struct
 222         include T
 223         let unit a = elevate (Wrapped.unit a)
 224     end)
 225     let elevate = T.elevate
 226   end
 227
 228
 229   (* We have to define BASE, S, and Make again for double-type-parameter monads. *)
 230   module type BASE2 = sig
 231     type ('x,'a) m
 232     type ('x,'a) result
 233     type ('x,'a) result_exn
 234     val unit : 'a -> ('x,'a) m
 235     val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
 236     val run : ('x,'a) m -> ('x,'a) result
 237     val run_exn : ('x,'a) m -> ('x,'a) result_exn
 238   end
 239   module type S2 = sig
 240     include BASE2
 241     val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
 242     val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
 243     val join : ('x,('x,'a) m) m -> ('x,'a) m
 244     val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
 245     val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
 246     val lift2 :  ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
 247     val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
 248     val do_when :  bool -> ('x,unit) m -> ('x,unit) m
 249     val do_unless :  bool -> ('x,unit) m -> ('x,unit) m
 250     val forever : ('x,'a) m -> ('x,'b) m
 251     val sequence : ('x,'a) m list -> ('x,'a list) m
 252     val sequence_ : ('x,'a) m list -> ('x,unit) m
 253   end
 254   module Make2(B : BASE2) : S2 with type ('x,'a) m = ('x,'a) B.m and type ('x,'a) result = ('x,'a) B.result and type ('x,'a) result_exn = ('x,'a) B.result_exn = struct
 255     (* code repetition, ugh *)
 256     include B
 257     let (>>=) = bind
 258     let (>>) u v = u >>= fun _ -> v
 259     let lift f u = u >>= fun a -> unit (f a)
 260     let join uu = uu >>= fun u -> u
 261     let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
 262     let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
 263     let (>=>) f g = fun a -> f a >>= g
 264     let do_when test u = if test then u else unit ()
 265     let do_unless test u = if test then unit () else u
 266     let rec forever u = u >> forever u
 267     let sequence ms =
 268       let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
 269         Util.fold_right op ms (unit [])
 270     let sequence_ ms =
 271       Util.fold_right (>>) ms (unit ())
 272   end
 273
 274   module type PLUSBASE2 = sig
 275     include BASE2
 276     val zero : unit -> ('x,'a) m
 277     val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
 278   end
 279   module type PLUS2 = sig
 280     type ('x,'a) m
 281     val zero : unit -> ('x,'a) m
 282     val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
 283     val guard : bool -> ('x,unit) m
 284     val sum : ('x,'a) m list -> ('x,'a) m
 285   end
 286   module MakeCatch2(B : PLUSBASE2) : PLUS2 with type ('x,'a) m = ('x,'a) B.m = struct
 287     type ('x,'a) m = ('x,'a) B.m
 288     (* code repetition, ugh *)
 289     let zero = B.zero
 290     let plus = B.plus
 291     let guard test = if test then B.unit () else zero ()
 292     let sum ms = Util.fold_right plus ms (zero ())
 293   end
 294   module MakeDistrib2 = MakeCatch2
 295
 296   (* Signatures for MonadT *)
 297   (* sig for Wrapped that include S and PLUS *)
 298   module type P2 = sig
 299     include S2
 300     include PLUS2 with type ('x,'a) m := ('x,'a) m
 301   end
 302   module type TRANS2 = sig
 303     module Wrapped : S2
 304     type ('x,'a) m
 305     type ('x,'a) result
 306     type ('x,'a) result_exn
 307     val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
 308     val run : ('x,'a) m -> ('x,'a) result
 309     val run_exn : ('x,'a) m -> ('x,'a) result_exn
 310     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
 311   end
 312   module MakeT2(T : TRANS2) = struct
 313     (* code repetition, ugh *)
 314     include Make2(struct
 315         include T
 316         let unit a = elevate (Wrapped.unit a)
 317     end)
 318     let elevate = T.elevate
 319   end
 320
 321 end
 322
 323
 324
 325
 326
 327 module Identity_monad : sig
 328   (* expose only the implementation of type `'a result` *)
 329   type 'a result = 'a
 330   type 'a result_exn = 'a
 331   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 332 end = struct
 333   module Base = struct
 334     type 'a m = 'a
 335     type 'a result = 'a
 336     type 'a result_exn = 'a
 337     let unit a = a
 338     let bind a f = f a
 339     let run a = a
 340     let run_exn a = a
 341   end
 342   include Monad.Make(Base)
 343 end
 344
 345
 346 module Maybe_monad : sig
 347   (* expose only the implementation of type `'a result` *)
 348   type 'a result = 'a option
 349   type 'a result_exn = 'a
 350   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 351   include Monad.PLUS with type 'a m := 'a m
 352   (* MaybeT transformer *)
 353   module T : functor (Wrapped : Monad.S) -> sig
 354     type 'a result = 'a option Wrapped.result
 355     type 'a result_exn = 'a Wrapped.result_exn
 356     include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 357     include Monad.PLUS with type 'a m := 'a m
 358     val elevate : 'a Wrapped.m -> 'a m
 359   end
 360   module T2 : functor (Wrapped : Monad.S2) -> sig
 361     type ('x,'a) result = ('x,'a option) Wrapped.result
 362     type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
 363     include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
 364     include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
 365     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
 366   end
 367 end = struct
 368   module Base = struct
 369    type 'a m = 'a option
 370    type 'a result = 'a option
 371    type 'a result_exn = 'a
 372    let unit a = Some a
 373    let bind u f = match u with Some a -> f a | None -> None
 374    let run u = u
 375    let run_exn u = match u with
 376      | Some a -> a
 377      | None -> failwith "no value"
 378    let zero () = None
 379    let plus u v = match u with None -> v | _ -> u
 380   end
 381   include Monad.Make(Base)
 382   include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m)
 383   module T(Wrapped : Monad.S) = struct
 384     module Trans = struct
 385       include Monad.MakeT(struct
 386         module Wrapped = Wrapped
 387         type 'a m = 'a option Wrapped.m
 388         type 'a result = 'a option Wrapped.result
 389         type 'a result_exn = 'a Wrapped.result_exn
 390         let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
 391         let bind u f = Wrapped.bind u (fun t -> match t with
 392           | Some a -> f a
 393           | None -> Wrapped.unit None)
 394         let run u = Wrapped.run u
 395         let run_exn u =
 396           let w = Wrapped.bind u (fun t -> match t with
 397             | Some a -> Wrapped.unit a
 398             | None -> failwith "no value")
 399           in Wrapped.run_exn w
 400       end)
 401       let zero () = Wrapped.unit None
 402       let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
 403     end
 404     include Trans
 405     include (Monad.MakeCatch(Trans) : Monad.PLUS with type 'a m := 'a m)
 406   end
 407   module T2(Wrapped : Monad.S2) = struct
 408     module Trans = struct
 409       include Monad.MakeT2(struct
 410         module Wrapped = Wrapped
 411         type ('x,'a) m = ('x,'a option) Wrapped.m
 412         type ('x,'a) result = ('x,'a option) Wrapped.result
 413         type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
 414         (* code repetition, ugh *)
 415         let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
 416         let bind u f = Wrapped.bind u (fun t -> match t with
 417           | Some a -> f a
 418           | None -> Wrapped.unit None)
 419         let run u = Wrapped.run u
 420         let run_exn u =
 421           let w = Wrapped.bind u (fun t -> match t with
 422             | Some a -> Wrapped.unit a
 423             | None -> failwith "no value")
 424           in Wrapped.run_exn w
 425       end)
 426       let zero () = Wrapped.unit None
 427       let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
 428     end
 429     include Trans
 430     include (Monad.MakeCatch2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
 431   end
 432 end
 433
 434
 435 module List_monad : sig
 436   (* declare additional operation, while still hiding implementation of type m *)
 437   type 'a result = 'a list
 438   type 'a result_exn = 'a
 439   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 440   include Monad.PLUS with type 'a m := 'a m
 441   val permute : 'a m -> 'a m m
 442   val select : 'a m -> ('a * 'a m) m
 443   (* ListT transformer *)
 444   module T : functor (Wrapped : Monad.S) -> sig
 445     type 'a result = 'a list Wrapped.result
 446     type 'a result_exn = 'a Wrapped.result_exn
 447     include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 448     include Monad.PLUS with type 'a m := 'a m
 449     val elevate : 'a Wrapped.m -> 'a m
 450     (* note that second argument is an 'a list, not the more abstract 'a m *)
 451     (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
 452     val distribute : ('a -> 'b Wrapped.m) -> 'a list -> 'b m
 453 (* TODO
 454     val permute : 'a m -> 'a m m
 455     val select : 'a m -> ('a * 'a m) m
 456 *)
 457   end
 458   module T2 : functor (Wrapped : Monad.S2) -> sig
 459     type ('x,'a) result = ('x,'a list) Wrapped.result
 460     type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
 461     include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
 462     include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
 463     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
 464     val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
 465   end
 466 end = struct
 467   module Base = struct
 468    type 'a m = 'a list
 469    type 'a result = 'a list
 470    type 'a result_exn = 'a
 471    let unit a = [a]
 472    let bind u f = Util.concat_map f u
 473    let run u = u
 474    let run_exn u = match u with
 475      | [] -> failwith "no values"
 476      | [a] -> a
 477      | many -> failwith "multiple values"
 478    let zero () = []
 479    let plus = Util.append
 480   end
 481   include Monad.Make(Base)
 482   include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
 483   (* let either u v = plus u v *)
 484   (* insert 3 [1;2] ~~> [[3;1;2]; [1;3;2]; [1;2;3]] *)
 485   let rec insert a u =
 486     plus (unit (a :: u)) (match u with
 487         | [] -> zero ()
 488         | x :: xs -> (insert a xs) >>= fun v -> unit (x :: v)
 489     )
 490   (* permute [1;2;3] ~~> [1;2;3]; [2;1;3]; [2;3;1]; [1;3;2]; [3;1;2]; [3;2;1] *)
 491   let rec permute u = match u with
 492       | [] -> unit []
 493       | x :: xs -> (permute xs) >>= (fun v -> insert x v)
 494   (* select [1;2;3] ~~> [(1,[2;3]); (2,[1;3]), (3;[1;2])] *)
 495   let rec select u = match u with
 496     | [] -> zero ()
 497     | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
 498   let base_plus = plus
 499   module T(Wrapped : Monad.S) = struct
 500     module Trans = struct
 501       (* Wrapped.sequence ms  ===
 502            let plus1 u v =
 503              Wrapped.bind u (fun x ->
 504              Wrapped.bind v (fun xs ->
 505              Wrapped.unit (x :: xs)))
 506            in Util.fold_right plus1 ms (Wrapped.unit []) *)
 507       (* distribute  ===  Wrapped.mapM; copies alist to its image under f *)
 508       let distribute f alist = Wrapped.sequence (Util.map f alist)
 509       include Monad.MakeT(struct
 510         module Wrapped = Wrapped
 511         type 'a m = 'a list Wrapped.m
 512         type 'a result = 'a list Wrapped.result
 513         type 'a result_exn = 'a Wrapped.result_exn
 514         let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
 515         let bind u f =
 516           Wrapped.bind u (fun ts ->
 517           Wrapped.bind (distribute f ts) (fun tts ->
 518           Wrapped.unit (Util.concat tts)))
 519         let run u = Wrapped.run u
 520         let run_exn u =
 521           let w = Wrapped.bind u (fun ts -> match ts with
 522             | [] -> failwith "no values"
 523             | [a] -> Wrapped.unit a
 524             | many -> failwith "multiple values"
 525           ) in Wrapped.run_exn w
 526       end)
 527       let zero () = Wrapped.unit []
 528       let plus u v =
 529         Wrapped.bind u (fun us ->
 530         Wrapped.bind v (fun vs ->
 531         Wrapped.unit (base_plus us vs)))
 532     end
 533     include Trans
 534     include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
 535 (*
 536     let permute : 'a m -> 'a m m
 537     let select : 'a m -> ('a * 'a m) m
 538 *)
 539   end
 540   module T2(Wrapped : Monad.S2) = struct
 541     module Trans = struct
 542       let distribute f alist = Wrapped.sequence (Util.map f alist)
 543       include Monad.MakeT2(struct
 544         module Wrapped = Wrapped
 545         type ('x,'a) m = ('x,'a list) Wrapped.m
 546         type ('x,'a) result = ('x,'a list) Wrapped.result
 547         type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
 548         (* code repetition, ugh *)
 549         let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
 550         let bind u f =
 551           Wrapped.bind u (fun ts ->
 552           Wrapped.bind (distribute f ts) (fun tts ->
 553           Wrapped.unit (Util.concat tts)))
 554         let run u = Wrapped.run u
 555         let run_exn u =
 556           let w = Wrapped.bind u (fun ts -> match ts with
 557             | [] -> failwith "no values"
 558             | [a] -> Wrapped.unit a
 559             | many -> failwith "multiple values"
 560           ) in Wrapped.run_exn w
 561       end)
 562       let zero () = Wrapped.unit []
 563       let plus u v =
 564         Wrapped.bind u (fun us ->
 565         Wrapped.bind v (fun vs ->
 566         Wrapped.unit (base_plus us vs)))
 567     end
 568     include Trans
 569     include (Monad.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
 570   end
 571 end
 572
 573
 574 (* must be parameterized on (struct type err = ... end) *)
 575 module Error_monad(Err : sig
 576   type err
 577   exception Exc of err
 578   (*
 579   val zero : unit -> err
 580   val plus : err -> err -> err
 581   *)
 582 end) : sig
 583   (* declare additional operations, while still hiding implementation of type m *)
 584   type err = Err.err
 585   type 'a error = Error of err | Success of 'a
 586   type 'a result = 'a
 587   type 'a result_exn = 'a
 588   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 589   (* include Monad.PLUS with type 'a m := 'a m *)
 590   val throw : err -> 'a m
 591   val catch : 'a m -> (err -> 'a m) -> 'a m
 592   (* ErrorT transformer *)
 593   module T : functor (Wrapped : Monad.S) -> sig
 594     type 'a result = 'a Wrapped.result
 595     type 'a result_exn = 'a Wrapped.result_exn
 596     include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 597     val elevate : 'a Wrapped.m -> 'a m
 598     val throw : err -> 'a m
 599     val catch : 'a m -> (err -> 'a m) -> 'a m
 600   end
 601   module T2 : functor (Wrapped : Monad.S2) -> sig
 602     type ('x,'a) result = ('x,'a) Wrapped.result
 603     type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
 604     include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
 605     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
 606     val throw : err -> ('x,'a) m
 607     val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
 608   end
 609 end = struct
 610   type err = Err.err
 611   type 'a error = Error of err | Success of 'a
 612   module Base = struct
 613     type 'a m = 'a error
 614     type 'a result = 'a
 615     type 'a result_exn = 'a
 616     let unit a = Success a
 617     let bind u f = match u with
 618       | Success a -> f a
 619       | Error e -> Error e (* input and output may be of different 'a types *)
 620     (* TODO: should run refrain from failing? *)
 621     let run u = match u with
 622       | Success a -> a
 623       | Error e -> raise (Err.Exc e)
 624     let run_exn = run
 625     (*
 626     let zero () = Error Err.zero
 627     let plus u v = match (u, v) with
 628       | Success _, _ -> u
 629       (* to satisfy (Catch) laws, plus u zero = u, even if u = Error _
 630        * otherwise, plus (Error _) v = v *)
 631       | Error _, _ when v = zero -> u
 632       (* combine errors *)
 633       | Error e1, Error e2 when u <> zero -> Error (Err.plus e1 e2)
 634       | Error _, _ -> v
 635     *)
 636   end
 637   include Monad.Make(Base)
 638   (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
 639   let throw e = Error e
 640   let catch u handler = match u with
 641     | Success _ -> u
 642     | Error e -> handler e
 643   module T(Wrapped : Monad.S) = struct
 644     module Trans = struct
 645       module Wrapped = Wrapped
 646       type 'a m = 'a error Wrapped.m
 647       type 'a result = 'a Wrapped.result
 648       type 'a result_exn = 'a Wrapped.result_exn
 649       let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
 650       let bind u f = Wrapped.bind u (fun t -> match t with
 651         | Success a -> f a
 652         | Error e -> Wrapped.unit (Error e))
 653       (* TODO: should run refrain from failing? *)
 654       let run u =
 655         let w = Wrapped.bind u (fun t -> match t with
 656           | Success a -> Wrapped.unit a
 657           (* | _ -> Wrapped.fail () *)
 658           | Error e -> raise (Err.Exc e))
 659         in Wrapped.run w
 660       let run_exn u =
 661         let w = Wrapped.bind u (fun t -> match t with
 662           | Success a -> Wrapped.unit a
 663           (* | _ -> Wrapped.fail () *)
 664           | Error e -> raise (Err.Exc e))
 665         in Wrapped.run_exn w
 666     end
 667     include Monad.MakeT(Trans)
 668     let throw e = Wrapped.unit (Error e)
 669     let catch u handler = Wrapped.bind u (fun t -> match t with
 670       | Success _ -> Wrapped.unit t
 671       | Error e -> handler e)
 672   end
 673   module T2(Wrapped : Monad.S2) = struct
 674     module Trans = struct
 675       module Wrapped = Wrapped
 676       type ('x,'a) m = ('x,'a error) Wrapped.m
 677       type ('x,'a) result = ('x,'a) Wrapped.result
 678       type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
 679       (* code repetition, ugh *)
 680       let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
 681       let bind u f = Wrapped.bind u (fun t -> match t with
 682         | Success a -> f a
 683         | Error e -> Wrapped.unit (Error e))
 684       let run u =
 685         let w = Wrapped.bind u (fun t -> match t with
 686           | Success a -> Wrapped.unit a
 687           | Error e -> raise (Err.Exc e))
 688         in Wrapped.run w
 689       let run_exn u =
 690         let w = Wrapped.bind u (fun t -> match t with
 691           | Success a -> Wrapped.unit a
 692           | Error e -> raise (Err.Exc e))
 693         in Wrapped.run_exn w
 694     end
 695     include Monad.MakeT2(Trans)
 696     let throw e = Wrapped.unit (Error e)
 697     let catch u handler = Wrapped.bind u (fun t -> match t with
 698       | Success _ -> Wrapped.unit t
 699       | Error e -> handler e)
 700   end
 701 end
 702
 703 (* pre-define common instance of Error_monad *)
 704 module Failure = Error_monad(struct
 705   type err = string
 706   exception Exc = Failure
 707   (*
 708   let zero = ""
 709   let plus s1 s2 = s1 ^ "\n" ^ s2
 710   *)
 711 end)
 712
 713 (* must be parameterized on (struct type env = ... end) *)
 714 module Reader_monad(Env : sig type env end) : sig
 715   (* declare additional operations, while still hiding implementation of type m *)
 716   type env = Env.env
 717   type 'a result = env -> 'a
 718   type 'a result_exn = env -> 'a
 719   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 720   val ask : env m
 721   val asks : (env -> 'a) -> 'a m
 722   val local : (env -> env) -> 'a m -> 'a m
 723   (* ReaderT transformer *)
 724   module T : functor (Wrapped : Monad.S) -> sig
 725     type 'a result = env -> 'a Wrapped.result
 726     type 'a result_exn = env -> 'a Wrapped.result_exn
 727     include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 728     val elevate : 'a Wrapped.m -> 'a m
 729     val ask : env m
 730     val asks : (env -> 'a) -> 'a m
 731     val local : (env -> env) -> 'a m -> 'a m
 732   end
 733   (* ReaderT transformer when wrapped monad has plus, zero *)
 734   module TP : functor (Wrapped : Monad.P) -> sig
 735     include module type of T(Wrapped)
 736     include Monad.PLUS with type 'a m := 'a m
 737   end
 738   module T2 : functor (Wrapped : Monad.S2) -> sig
 739     type ('x,'a) result = env -> ('x,'a) Wrapped.result
 740     type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
 741     include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
 742     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
 743     val ask : ('x,env) m
 744     val asks : (env -> 'a) -> ('x,'a) m
 745     val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
 746   end
 747   module TP2 : functor (Wrapped : Monad.P2) -> sig
 748     include module type of T2(Wrapped)
 749     include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
 750   end
 751 end = struct
 752   type env = Env.env
 753   module Base = struct
 754     type 'a m = env -> 'a
 755     type 'a result = env -> 'a
 756     type 'a result_exn = env -> 'a
 757     let unit a = fun e -> a
 758     let bind u f = fun e -> let a = u e in let u' = f a in u' e
 759     let run u = fun e -> u e
 760     let run_exn = run
 761   end
 762   include Monad.Make(Base)
 763   let ask = fun e -> e
 764   let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
 765   let local modifier u = fun e -> u (modifier e)
 766   module T(Wrapped : Monad.S) = struct
 767     module Trans = struct
 768       module Wrapped = Wrapped
 769       type 'a m = env -> 'a Wrapped.m
 770       type 'a result = env -> 'a Wrapped.result
 771       type 'a result_exn = env -> 'a Wrapped.result_exn
 772       let elevate w = fun e -> w
 773       let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
 774       let run u = fun e -> Wrapped.run (u e)
 775       let run_exn u = fun e -> Wrapped.run_exn (u e)
 776     end
 777     include Monad.MakeT(Trans)
 778     let ask = fun e -> Wrapped.unit e
 779     let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
 780     let local modifier u = fun e -> u (modifier e)
 781   end
 782   module TP(Wrapped : Monad.P) = struct
 783     module TransP = struct
 784       include T(Wrapped)
 785       let plus u v = fun s -> Wrapped.plus (u s) (v s)
 786       let zero () = elevate (Wrapped.zero ())
 787       let asks selector = ask >>= (fun e ->
 788         try unit (selector e)
 789         with Not_found -> fun e -> Wrapped.zero ())
 790     end
 791     include TransP
 792     include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
 793   end
 794   module T2(Wrapped : Monad.S2) = struct
 795     module Trans = struct
 796       module Wrapped = Wrapped
 797       type ('x,'a) m = env -> ('x,'a) Wrapped.m
 798       type ('x,'a) result = env -> ('x,'a) Wrapped.result
 799       type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
 800       (* code repetition, ugh *)
 801       let elevate w = fun e -> w
 802       let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
 803       let run u = fun e -> Wrapped.run (u e)
 804       let run_exn u = fun e -> Wrapped.run_exn (u e)
 805     end
 806     include Monad.MakeT2(Trans)
 807     let ask = fun e -> Wrapped.unit e
 808     let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
 809     let local modifier u = fun e -> u (modifier e)
 810   end
 811   module TP2(Wrapped : Monad.P2) = struct
 812     module TransP = struct
 813       (* code repetition, ugh *)
 814       include T2(Wrapped)
 815       let plus u v = fun s -> Wrapped.plus (u s) (v s)
 816       let zero () = elevate (Wrapped.zero ())
 817       let asks selector = ask >>= (fun e ->
 818         try unit (selector e)
 819         with Not_found -> fun e -> Wrapped.zero ())
 820     end
 821     include TransP
 822     include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
 823   end
 824 end
 825
 826
 827 (* must be parameterized on (struct type store = ... end) *)
 828 module State_monad(Store : sig type store end) : sig
 829   (* declare additional operations, while still hiding implementation of type m *)
 830   type store = Store.store
 831   type 'a result = store -> 'a * store
 832   type 'a result_exn = store -> 'a
 833   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 834   val get : store m
 835   val gets : (store -> 'a) -> 'a m
 836   val put : store -> unit m
 837   val puts : (store -> store) -> unit m
 838   (* StateT transformer *)
 839   module T : functor (Wrapped : Monad.S) -> sig
 840     type 'a result = store -> ('a * store) Wrapped.result
 841     type 'a result_exn = store -> 'a Wrapped.result_exn
 842     include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 843     val elevate : 'a Wrapped.m -> 'a m
 844     val get : store m
 845     val gets : (store -> 'a) -> 'a m
 846     val put : store -> unit m
 847     val puts : (store -> store) -> unit m
 848   end
 849   (* StateT transformer when wrapped monad has plus, zero *)
 850   module TP : functor (Wrapped : Monad.P) -> sig
 851     include module type of T(Wrapped)
 852     include Monad.PLUS with type 'a m := 'a m
 853   end
 854   module T2 : functor (Wrapped : Monad.S2) -> sig
 855     type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
 856     type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
 857     include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
 858     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
 859     val get : ('x,store) m
 860     val gets : (store -> 'a) -> ('x,'a) m
 861     val put : store -> ('x,unit) m
 862     val puts : (store -> store) -> ('x,unit) m
 863   end
 864   module TP2 : functor (Wrapped : Monad.P2) -> sig
 865     include module type of T2(Wrapped)
 866     include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
 867   end
 868 end = struct
 869   type store = Store.store
 870   module Base = struct
 871     type 'a m = store -> 'a * store
 872     type 'a result = store -> 'a * store
 873     type 'a result_exn = store -> 'a
 874     let unit a = fun s -> (a, s)
 875     let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
 876     let run u = fun s -> (u s)
 877     let run_exn u = fun s -> fst (u s)
 878   end
 879   include Monad.Make(Base)
 880   let get = fun s -> (s, s)
 881   let gets viewer = fun s -> (viewer s, s) (* may fail *)
 882   let put s = fun _ -> ((), s)
 883   let puts modifier = fun s -> ((), modifier s)
 884   module T(Wrapped : Monad.S) = struct
 885     module Trans = struct
 886       module Wrapped = Wrapped
 887       type 'a m = store -> ('a * store) Wrapped.m
 888       type 'a result = store -> ('a * store) Wrapped.result
 889       type 'a result_exn = store -> 'a Wrapped.result_exn
 890       let elevate w = fun s ->
 891         Wrapped.bind w (fun a -> Wrapped.unit (a, s))
 892       let bind u f = fun s ->
 893         Wrapped.bind (u s) (fun (a, s') -> f a s')
 894       let run u = fun s -> Wrapped.run (u s)
 895       let run_exn u = fun s ->
 896         let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
 897         in Wrapped.run_exn w
 898     end
 899     include Monad.MakeT(Trans)
 900     let get = fun s -> Wrapped.unit (s, s)
 901     let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
 902     let put s = fun _ -> Wrapped.unit ((), s)
 903     let puts modifier = fun s -> Wrapped.unit ((), modifier s)
 904   end
 905   module TP(Wrapped : Monad.P) = struct
 906     module TransP = struct
 907       include T(Wrapped)
 908       let plus u v = fun s -> Wrapped.plus (u s) (v s)
 909       let zero () = elevate (Wrapped.zero ())
 910     end
 911     let gets viewer = fun s ->
 912       try Wrapped.unit (viewer s, s)
 913       with Not_found -> Wrapped.zero ()
 914     include TransP
 915     include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
 916   end
 917   module T2(Wrapped : Monad.S2) = struct
 918     module Trans = struct
 919       module Wrapped = Wrapped
 920       type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
 921       type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
 922       type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
 923       (* code repetition, ugh *)
 924       let elevate w = fun s ->
 925         Wrapped.bind w (fun a -> Wrapped.unit (a, s))
 926       let bind u f = fun s ->
 927         Wrapped.bind (u s) (fun (a, s') -> f a s')
 928       let run u = fun s -> Wrapped.run (u s)
 929       let run_exn u = fun s ->
 930         let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
 931         in Wrapped.run_exn w
 932     end
 933     include Monad.MakeT2(Trans)
 934     let get = fun s -> Wrapped.unit (s, s)
 935     let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
 936     let put s = fun _ -> Wrapped.unit ((), s)
 937     let puts modifier = fun s -> Wrapped.unit ((), modifier s)
 938   end
 939   module TP2(Wrapped : Monad.P2) = struct
 940     module TransP = struct
 941       include T2(Wrapped)
 942       let plus u v = fun s -> Wrapped.plus (u s) (v s)
 943       let zero () = elevate (Wrapped.zero ())
 944     end
 945     let gets viewer = fun s ->
 946       try Wrapped.unit (viewer s, s)
 947       with Not_found -> Wrapped.zero ()
 948     include TransP
 949     include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
 950   end
 951 end
 952
 953 (* State monad with different interface (structured store) *)
 954 module Ref_monad(V : sig
 955   type value
 956 end) : sig
 957   type ref
 958   type value = V.value
 959   type 'a result = 'a
 960   type 'a result_exn = 'a
 961   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 962   val newref : value -> ref m
 963   val deref : ref -> value m
 964   val change : ref -> value -> unit m
 965   (* RefT transformer *)
 966   module T : functor (Wrapped : Monad.S) -> sig
 967     type 'a result = 'a Wrapped.result
 968     type 'a result_exn = 'a Wrapped.result_exn
 969     include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
 970     val elevate : 'a Wrapped.m -> 'a m
 971     val newref : value -> ref m
 972     val deref : ref -> value m
 973     val change : ref -> value -> unit m
 974   end
 975   (* RefT transformer when wrapped monad has plus, zero *)
 976   module TP : functor (Wrapped : Monad.P) -> sig
 977     include module type of T(Wrapped)
 978     include Monad.PLUS with type 'a m := 'a m
 979   end
 980   module T2 : functor (Wrapped : Monad.S2) -> sig
 981     type ('x,'a) result = ('x,'a) Wrapped.result
 982     type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
 983     include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
 984     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
 985     val newref : value -> ('x,ref) m
 986     val deref : ref -> ('x,value) m
 987     val change : ref -> value -> ('x,unit) m
 988   end
 989   module TP2 : functor (Wrapped : Monad.P2) -> sig
 990     include module type of T2(Wrapped)
 991     include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
 992   end
 993 end = struct
 994   type ref = int
 995   type value = V.value
 996   module D = Map.Make(struct type t = ref let compare = compare end)
 997   type dict = { next: ref; tree : value D.t }
 998   let empty = { next = 0; tree = D.empty }
 999   let alloc (value : value) (d : dict) =
1000     (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
1001   let read (key : ref) (d : dict) =
1002     D.find key d.tree
1003   let write (key : ref) (value : value) (d : dict) =
1004     { next = d.next; tree = D.add key value d.tree }
1005   module Base = struct
1006     type 'a m = dict -> 'a * dict
1007     type 'a result = 'a
1008     type 'a result_exn = 'a
1009     let unit a = fun s -> (a, s)
1010     let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
1011     let run u = fst (u empty)
1012     let run_exn = run
1013   end
1014   include Monad.Make(Base)
1015   let newref value = fun s -> alloc value s
1016   let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
1017   let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
1018   module T(Wrapped : Monad.S) = struct
1019     module Trans = struct
1020       module Wrapped = Wrapped
1021       type 'a m = dict -> ('a * dict) Wrapped.m
1022       type 'a result = 'a Wrapped.result
1023       type 'a result_exn = 'a Wrapped.result_exn
1024       let elevate w = fun s ->
1025         Wrapped.bind w (fun a -> Wrapped.unit (a, s))
1026       let bind u f = fun s ->
1027         Wrapped.bind (u s) (fun (a, s') -> f a s')
1028       let run u =
1029         let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1030         in Wrapped.run w
1031       let run_exn u =
1032         let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1033         in Wrapped.run_exn w
1034     end
1035     include Monad.MakeT(Trans)
1036     let newref value = fun s -> Wrapped.unit (alloc value s)
1037     let deref key = fun s -> Wrapped.unit (read key s, s)
1038     let change key value = fun s -> Wrapped.unit ((), write key value s)
1039   end
1040   module TP(Wrapped : Monad.P) = struct
1041     module TransP = struct
1042       include T(Wrapped)
1043       let plus u v = fun s -> Wrapped.plus (u s) (v s)
1044       let zero () = elevate (Wrapped.zero ())
1045     end
1046     include TransP
1047     include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
1048   end
1049   module T2(Wrapped : Monad.S2) = struct
1050     module Trans = struct
1051       module Wrapped = Wrapped
1052       type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
1053       type ('x,'a) result = ('x,'a) Wrapped.result
1054       type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
1055       (* code repetition, ugh *)
1056       let elevate w = fun s ->
1057         Wrapped.bind w (fun a -> Wrapped.unit (a, s))
1058       let bind u f = fun s ->
1059         Wrapped.bind (u s) (fun (a, s') -> f a s')
1060       let run u =
1061         let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1062         in Wrapped.run w
1063       let run_exn u =
1064         let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
1065         in Wrapped.run_exn w
1066     end
1067     include Monad.MakeT2(Trans)
1068     let newref value = fun s -> Wrapped.unit (alloc value s)
1069     let deref key = fun s -> Wrapped.unit (read key s, s)
1070     let change key value = fun s -> Wrapped.unit ((), write key value s)
1071   end
1072   module TP2(Wrapped : Monad.P2) = struct
1073     module TransP = struct
1074       include T2(Wrapped)
1075       let plus u v = fun s -> Wrapped.plus (u s) (v s)
1076       let zero () = elevate (Wrapped.zero ())
1077     end
1078     include TransP
1079     include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
1080   end
1081 end
1082
1083
1084 (* must be parameterized on (struct type log = ... end) *)
1085 module Writer_monad(Log : sig
1086   type log
1087   val zero : log
1088   val plus : log -> log -> log
1089 end) : sig
1090   (* declare additional operations, while still hiding implementation of type m *)
1091   type log = Log.log
1092   type 'a result = 'a * log
1093   type 'a result_exn = 'a * log
1094   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1095   val tell : log -> unit m
1096   val listen : 'a m -> ('a * log) m
1097   val listens : (log -> 'b) -> 'a m -> ('a * 'b) m
1098   (* val pass : ('a * (log -> log)) m -> 'a m *)
1099   val censor : (log -> log) -> 'a m -> 'a m
1100 end = struct
1101   type log = Log.log
1102   module Base = struct
1103     type 'a m = 'a * log
1104     type 'a result = 'a * log
1105     type 'a result_exn = 'a * log
1106     let unit a = (a, Log.zero)
1107     let bind (a, w) f = let (a', w') = f a in (a', Log.plus w w')
1108     let run u = u
1109     let run_exn = run
1110   end
1111   include Monad.Make(Base)
1112   let tell entries = ((), entries) (* add entries to log *)
1113   let listen (a, w) = ((a, w), w)
1114   let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
1115   let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
1116   let censor f u = pass (u >>= fun a -> unit (a, f))
1117 end
1118
1119 (* pre-define simple Writer *)
1120 module Writer1 = Writer_monad(struct
1121   type log = string
1122   let zero = ""
1123   let plus s1 s2 = s1 ^ "\n" ^ s2
1124 end)
1125
1126 (* slightly more efficient Writer *)
1127 module Writer2 = struct
1128   include Writer_monad(struct
1129     type log = string list
1130     let zero = []
1131     let plus w w' = Util.append w' w
1132   end)
1133   let tell_string s = tell [s]
1134   let tell entries = tell (Util.reverse entries)
1135   let run u = let (a, w) = run u in (a, Util.reverse w)
1136   let run_exn = run
1137 end
1138
1139
1140 module IO_monad : sig
1141   (* declare additional operation, while still hiding implementation of type m *)
1142   type 'a result = 'a
1143   type 'a result_exn = 'a
1144   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1145   val printf : ('a, unit, string, unit m) format4 -> 'a
1146   val print_string : string -> unit m
1147   val print_int : int -> unit m
1148   val print_hex : int -> unit m
1149   val print_bool : bool -> unit m
1150 end = struct
1151   module Base = struct
1152     type 'a m = { run : unit -> unit; value : 'a }
1153     type 'a result = 'a
1154     type 'a result_exn = 'a
1155     let unit a = { run = (fun () -> ()); value = a }
1156     let bind (a : 'a m) (f: 'a -> 'b m) : 'b m =
1157      let fres = f a.value in
1158        { run = (fun () -> a.run (); fres.run ()); value = fres.value }
1159     let run a = let () = a.run () in a.value
1160     let run_exn = run
1161   end
1162   include Monad.Make(Base)
1163   let printf fmt =
1164     Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
1165   let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
1166   let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
1167   let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
1168   let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
1169 end
1170
1171 (*
1172 module Continuation_monad : sig
1173   (* expose only the implementation of type `('r,'a) result` *)
1174   type 'a m
1175   type 'a result = 'a m
1176   type 'a result_exn = 'a m
1177   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn and type 'a m := 'a m
1178   (* val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m *)
1179   (* misses that the answer types of all the cont's must be the same *)
1180   val callcc : (('a -> 'b m) -> 'a m) -> 'a m
1181   (* val reset : ('a,'a) m -> ('r,'a) m *)
1182   val reset : 'a m -> 'a m
1183   (* val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m *)
1184   (* misses that the answer types of second and third continuations must be b *)
1185   val shift : (('a -> 'b m) -> 'b m) -> 'a m
1186   (* overwrite the run declaration in S, because I can't declare 'a result =
1187    * this polymorphic type (complains that 'r is unbound *)
1188   val runk : 'a m -> ('a -> 'r) -> 'r
1189   val run0 : 'a m -> 'a
1190 end = struct
1191   let id = fun i -> i
1192   module Base = struct
1193     (* 'r is result type of whole computation *)
1194     type 'a m = { cont : 'r. ('a -> 'r) -> 'r }
1195     type 'a result = 'a m
1196     type 'a result_exn = 'a m
1197     let unit a =
1198       let cont : 'r. ('a -> 'r) -> 'r =
1199         fun k -> k a
1200       in { cont }
1201     let bind u f =
1202       let cont : 'r. ('a -> 'r) -> 'r =
1203         fun k -> u.cont (fun a -> (f a).cont k)
1204       in { cont }
1205     let run (u : 'a m) : 'a result = u
1206     let run_exn (u : 'a m) : 'a result_exn = u
1207     let callcc f =
1208       let cont : 'r. ('a -> 'r) -> 'r =
1209           (* Can't figure out how to make the type polymorphic enough
1210            * to satisfy the OCaml type-checker (it's ('a -> 'r) -> 'r
1211            * instead of 'r. ('a -> 'r) -> 'r); so we have to fudge
1212            * with Obj.magic... which tells OCaml's type checker to
1213            * relax, the supplied value has whatever type the context
1214            * needs it to have. *)
1215           fun k ->
1216           let usek a = { cont = Obj.magic (fun _ -> k a) }
1217           in (f usek).cont k
1218       in { cont }
1219     let reset u = unit (u.cont id)
1220     let shift (f : ('a -> 'b m) -> 'b m) : 'a m =
1221       let cont = fun k ->
1222         (f (fun a -> unit (k a))).cont id
1223       in { cont = Obj.magic cont }
1224     let runk u k = (u.cont : ('a -> 'r) -> 'r) k
1225     let run0 u = runk u id
1226   end
1227   include Monad.Make(Base)
1228   let callcc = Base.callcc
1229   let reset = Base.reset
1230   let shift = Base.shift
1231   let runk = Base.runk
1232   let run0 = Base.run0
1233 end
1234  *)
1235
1236 (* This two-type parameter version works without Obj.magic *)
1237 module Continuation_monad : sig
1238   (* expose only the implementation of type `('r,'a) result` *)
1239   type ('r,'a) m
1240   type ('r,'a) result = ('r,'a) m
1241   type ('r,'a) result_exn = ('a -> 'r) -> 'r
1242   include Monad.S2 with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn and type ('r,'a) m := ('r,'a) m
1243   val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
1244   val reset : ('a,'a) m -> ('r,'a) m
1245   val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
1246   val abort : ('a,'a) m -> ('a,'b) m
1247   val run0 : ('a,'a) m -> 'a
1248 end = struct
1249   let id = fun i -> i
1250   module Base = struct
1251     (* 'r is result type of whole computation *)
1252     type ('r,'a) m = ('a -> 'r) -> 'r
1253     type ('r,'a) result = ('a -> 'r) -> 'r
1254     type ('r,'a) result_exn = ('r,'a) result
1255     let unit a = (fun k -> k a)
1256     let bind u f = (fun k -> (u) (fun a -> (f a) k))
1257     let run u k = (u) k
1258     let run_exn = run
1259   end
1260   include Monad.Make2(Base)
1261   let callcc f = (fun k ->
1262     let usek a = (fun _ -> k a)
1263     in (f usek) k)
1264   (*
1265   val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
1266   val throw : ('a -> 'r) -> 'a -> ('r,'b) m
1267   let callcc f = fun k -> f k k
1268   let throw k a = fun _ -> k a
1269   *)
1270   (* from http://www.haskell.org/haskellwiki/MonadCont_done_right *)
1271   let reset u = unit ((u) id)
1272   let shift f = (fun k -> (f (fun a -> unit (k a))) id)
1273   let abort a = shift (fun _ -> a)
1274   let run0 (u : ('a,'a) m) = (u) id
1275 end
1276
1277
1278 (*
1279  * Scheme:
1280  * (define (example n)
1281  *    (let ([u (let/cc k ; type int -> int pair
1282  *               (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
1283  *                 (+ 1 (car v))))]) ; int
1284  *      (cons u 0))) ; int pair
1285  * ; (example 10) ~~> '(111 . 0)
1286  * ; (example -10) ~~> '(0 . 0)
1287  *
1288  * OCaml monads:
1289  * let example n : (int * int) =
1290  *   Continuation_monad.(let u = callcc (fun k ->
1291  *       (if n < 0 then k 0 else unit [n + 100])
1292  *       (* all of the following is skipped by k 0; the end type int is k's input type *)
1293  *       >>= fun [x] -> unit (x + 1)
1294  *   )
1295  *   (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1296  *   >>= fun x -> unit (x, 0)
1297  *   in run u)
1298  *
1299  *
1300  * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1301  * let example1 () : int =
1302  *   Continuation_monad.(let v = reset (
1303  *       let u = shift (fun k -> unit (10 + 1))
1304  *       in u >>= fun x -> unit (100 + x)
1305  *     ) in let w = v >>= fun x -> unit (1000 + x)
1306  *     in run w)
1307  *
1308  * (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1309  * let example2 () =
1310  *   Continuation_monad.(let v = reset (
1311  *       let u = shift (fun k -> k (10 :: [1]))
1312  *       in u >>= fun x -> unit (100 :: x)
1313  *     ) in let w = v >>= fun x -> unit (1000 :: x)
1314  *     in run w)
1315  *
1316  * (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1317  * let example3 () =
1318  *   Continuation_monad.(let v = reset (
1319  *       let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1320  *       in u >>= fun x -> unit (100 :: x)
1321  *     ) in let w = v >>= fun x -> unit (1000 :: x)
1322  *     in run w)
1323  *
1324  * (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1325  * (* not sure if this example can be typed without a sum-type *)
1326  *
1327  * (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1328  * let example5 () : int =
1329  *   Continuation_monad.(let v = reset (
1330  *       let u = shift (fun k -> k 1 >>= fun x -> k x)
1331  *       in u >>= fun x -> unit (10 + x)
1332  *     ) in let w = v >>= fun x -> unit (100 + x)
1333  *     in run w)
1334  *
1335  *)
1336
1337
1338 module Leaf_monad : sig
1339   (* We implement the type as `'a tree option` because it has a natural`plus`,
1340    * and the rest of the library expects that `plus` and `zero` will come together. *)
1341   type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1342   type 'a result = 'a tree option
1343   type 'a result_exn = 'a tree
1344   include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1345   include Monad.PLUS with type 'a m := 'a m
1346   (* LeafT transformer *)
1347   module T : functor (Wrapped : Monad.S) -> sig
1348     type 'a result = 'a tree option Wrapped.result
1349     type 'a result_exn = 'a tree Wrapped.result_exn
1350     include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
1351     include Monad.PLUS with type 'a m := 'a m
1352     val elevate : 'a Wrapped.m -> 'a m
1353     (* note that second argument is an 'a tree?, not the more abstract 'a m *)
1354     (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
1355     val distribute : ('a -> 'b Wrapped.m) -> 'a tree option -> 'b m
1356   end
1357   module T2 : functor (Wrapped : Monad.S2) -> sig
1358     type ('x,'a) result = ('x,'a tree option) Wrapped.result
1359     type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1360     include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
1361     include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
1362     val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
1363     val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
1364   end
1365 end = struct
1366   type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
1367   (* uses supplied plus and zero to copy t to its image under f *)
1368   let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
1369       | None -> zero ()
1370       | Some ts -> let rec loop ts = (match ts with
1371                      | Leaf a -> f a
1372                      | Node (l, r) ->
1373                          (* recursive application of f may delete a branch *)
1374                          plus (loop l) (loop r)
1375                    ) in loop ts
1376   module Base = struct
1377     type 'a m = 'a tree option
1378     type 'a result = 'a tree option
1379     type 'a result_exn = 'a tree
1380     let unit a = Some (Leaf a)
1381     let zero () = None
1382     let plus u v = match (u, v) with
1383       | None, _ -> v
1384       | _, None -> u
1385       | Some us, Some vs -> Some (Node (us, vs))
1386     let bind u f = mapT f u zero plus
1387     let run u = u
1388     let run_exn u = match u with
1389       | None -> failwith "no values"
1390       (*
1391       | Some (Leaf a) -> a
1392       | many -> failwith "multiple values"
1393       *)
1394       | Some us -> us
1395   end
1396   include Monad.Make(Base)
1397   include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
1398   let base_plus = plus
1399   let base_lift = lift
1400   module T(Wrapped : Monad.S) = struct
1401     module Trans = struct
1402       let zero () = Wrapped.unit None
1403       let plus u v =
1404         Wrapped.bind u (fun us ->
1405         Wrapped.bind v (fun vs ->
1406         Wrapped.unit (base_plus us vs)))
1407       include Monad.MakeT(struct
1408         module Wrapped = Wrapped
1409         type 'a m = 'a tree option Wrapped.m
1410         type 'a result = 'a tree option Wrapped.result
1411         type 'a result_exn = 'a tree Wrapped.result_exn
1412         let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1413         let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1414         let run u = Wrapped.run u
1415         let run_exn u =
1416             let w = Wrapped.bind u (fun t -> match t with
1417               | None -> failwith "no values"
1418               | Some ts -> Wrapped.unit ts)
1419             in Wrapped.run_exn w
1420       end)
1421     end
1422     include Trans
1423     include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
1424     (* let distribute f t = mapT (fun a -> a) (base_lift (fun a -> elevate (f a)) t) zero plus *)
1425     let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1426   end
1427   module T2(Wrapped : Monad.S2) = struct
1428     module Trans = struct
1429       let zero () = Wrapped.unit None
1430       let plus u v =
1431         Wrapped.bind u (fun us ->
1432         Wrapped.bind v (fun vs ->
1433         Wrapped.unit (base_plus us vs)))
1434       include Monad.MakeT2(struct
1435         module Wrapped = Wrapped
1436         type ('x,'a) m = ('x,'a tree option) Wrapped.m
1437         type ('x,'a) result = ('x,'a tree option) Wrapped.result
1438         type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
1439         (* code repetition, ugh *)
1440         let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
1441         let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
1442         let run u = Wrapped.run u
1443         let run_exn u =
1444             let w = Wrapped.bind u (fun t -> match t with
1445               | None -> failwith "no values"
1446               | Some ts -> Wrapped.unit ts)
1447             in Wrapped.run_exn w
1448       end)
1449     end
1450     include Trans
1451     include (Monad.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
1452     let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
1453   end
1454 end
1455
1456
1457 module L = List_monad;;
1458 module R = Reader_monad(struct type env = int -> int end);;
1459 module S = State_monad(struct type store = int end);;
1460 module T = Leaf_monad;;
1461 module LR = L.T(R);;
1462 module LS = L.T(S);;
1463 module TL = T.T(L);;
1464 module TR = T.T(R);;
1465 module TS = T.T(S);;
1466 module C = Continuation_monad
1467 module TC = T.T2(C);;
1468
1469
1470 print_endline "================================================";;
1471
1472 let t1 = Some (T.Node (T.Node (T.Leaf 2, T.Leaf 3), T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11))));;
1473
1474 let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
1475 TS.run ts 0;;
1476 (*
1477 - : int T.tree option * S.store =
1478 (Some
1479   (T.Node
1480     (T.Node (T.Leaf 2, T.Leaf 3),
1481      T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
1482  5)
1483 *)
1484
1485 let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
1486 TS.run_exn ts2 0;;
1487 (*
1488 - : (int * S.store) T.tree option * S.store =
1489 (Some
1490   (T.Node
1491     (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
1492      T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
1493  5)
1494 *)
1495
1496 let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
1497 TR.run_exn tr (fun i -> i+i);;
1498 (*
1499 - : int T.tree option =
1500 Some
1501  (T.Node
1502    (T.Node (T.Leaf 4, T.Leaf 6),
1503     T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
1504 *)
1505
1506 let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
1507 TL.run_exn tl;;
1508 (*
1509 - : (int * int) TL.result =
1510 [Some
1511   (T.Node
1512     (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
1513      T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
1514 *)
1515
1516 let l2 = [1;2;3;4;5];;
1517 let t2 = Some (T.Node (T.Leaf 1, (T.Node (T.Node (T.Node (T.Leaf 2, T.Leaf 3), T.Leaf 4), T.Leaf 5))));;
1518
1519 LR.(run (distribute (fun i -> R.(asks (fun e -> e i))) l2 >>= fun j -> LR.(plus (unit j) (unit (succ j))))) (fun i -> i*10);;
1520 (* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
1521
1522 TR.(run_exn (distribute (fun i -> R.(asks (fun e -> e i))) t2 >>= fun j -> TR.(plus (unit j) (unit (succ j))))) (fun i -> i*10);;
1523 (*
1524 int T.tree option =
1525 Some
1526  (T.Node
1527    (T.Node (T.Leaf 10, T.Leaf 11),
1528     T.Node
1529      (T.Node
1530        (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
1531         T.Node (T.Leaf 40, T.Leaf 41)),
1532       T.Node (T.Leaf 50, T.Leaf 51))))
1533  *)
1534
1535 LS.run (LS.distribute (fun i -> if i = -1 then S.get else if i < 0 then S.(puts succ >> unit 0) else S.unit i) [10;-1;-2;-1;20]) 0;;
1536 (*
1537 - : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
1538 *)
1539
1540
1541 let id : 'z. 'z -> 'z = fun x -> x
1542
1543 let example n : (int * int) =
1544   Continuation_monad.(let u = callcc (fun k ->
1545       (if n < 0 then k 0 else unit [n + 100])
1546       (* all of the following is skipped by k 0; the end type int is k's input type *)
1547       >>= fun [x] -> unit (x + 1)
1548   )
1549   (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
1550   >>= fun x -> unit (x, 0)
1551   in run0 u)
1552
1553
1554 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 1))))) ~~> 1011 *)
1555 let example1 () : int =
1556   Continuation_monad.(let v = reset (
1557       let u = shift (fun k -> unit (10 + 1))
1558       in u >>= fun x -> unit (100 + x)
1559     ) in let w = v >>= fun x -> unit (1000 + x)
1560     in run0 w)
1561
1562 (* (+ 1000 (prompt (+ 100 (shift k (k (+ 10 1)))))) ~~> 1111 *)
1563 let example2 () =
1564   Continuation_monad.(let v = reset (
1565       let u = shift (fun k -> k (10 :: [1]))
1566       in u >>= fun x -> unit (100 :: x)
1567     ) in let w = v >>= fun x -> unit (1000 :: x)
1568     in run0 w)
1569
1570 (* (+ 1000 (prompt (+ 100 (shift k (+ 10 (k 1)))))) ~~> 1111 but added differently *)
1571 let example3 () =
1572   Continuation_monad.(let v = reset (
1573       let u = shift (fun k -> k [1] >>= fun x -> unit (10 :: x))
1574       in u >>= fun x -> unit (100 :: x)
1575     ) in let w = v >>= fun x -> unit (1000 :: x)
1576     in run0 w)
1577
1578 (* (+ 100 ((prompt (+ 10 (shift k k))) 1)) ~~> 111 *)
1579 (* not sure if this example can be typed without a sum-type *)
1580
1581 (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
1582 let example5 () : int =
1583   Continuation_monad.(let v = reset (
1584       let u = shift (fun k -> k 1 >>= fun x -> k x)
1585       in u >>= fun x -> unit (10 + x)
1586     ) in let w = v >>= fun x -> unit (100 + x)
1587     in run0 w)
1588
1589
1590 ;;
1591
1592 (1011, 1111, 1111, 121);;
1593 (example1(), example2(), example3(), example5());;
1594 ((111,0), (0,0));;
1595 (example ~+10, example ~-10);;
1596
1597 let testc df ic =
1598     C.run_exn TC.(run (distribute df t1)) ic;;
1599
1600
1601 (*
1602 (* do nothing *)
1603 let initial_continuation = fun t -> t in
1604 TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
1605 *)
1606 testc (C.unit) id;;
1607
1608 (*
1609 (* count leaves, using continuation *)
1610 let initial_continuation = fun t -> 0 in
1611 TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
1612 *)
1613
1614 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
1615
1616 (*
1617 (* convert tree to list of leaves *)
1618 let initial_continuation = fun t -> [] in
1619 TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
1620 *)
1621
1622 testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
1623
1624 (*
1625 (* square each leaf using continuation *)
1626 let initial_continuation = fun t -> t in
1627 TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
1628 *)
1629
1630 testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
1631
1632
1633 (*
1634 (* replace leaves with list, using continuation *)
1635 let initial_continuation = fun t -> t in
1636 TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
1637 *)
1638
1639 testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;
1640