--- /dev/null
+(*
+ * tree_monadize.ml
+ *
+ * If you've got some block of code that uses `unit`s and `bind`s, and you
+ * want to interpret it alternately using this monad, that monad, or another
+ * monad, you can use OCaml's module system. You'd write your code like this:
+ *)
+
+module Reader_monad = struct
+ (* change this to suit your needs *)
+ type env = int -> int;;
+
+ type 'a m = env -> 'a;;
+ let unit a : 'a m = fun e -> a;;
+ let bind (u : 'a m) (f : 'a -> 'b m) : 'b m =
+ fun e -> f (u e) e;;
+end
+
+module State_monad = struct
+ (* change this to suit your needs *)
+ type store = int;;
+
+ type 'a m = store -> 'a * store;;
+ let unit a : 'a m = fun s -> (a, s);;
+ let bind (u : 'a m) (f : 'a -> 'b m) : 'b m =
+ fun s -> (let (a, s') = u s in (f a) s');;
+end
+
+module List_monad = struct
+ type 'a m = 'a list;;
+ let unit a : 'a m = [a];;
+ let bind (u: 'a m) (f : 'a -> 'b m) : 'b m =
+ List.concat(List.map f u);;
+end
+
+(*
+ * Then you can replace code that looks like this:
+ * ... reader_bind ...
+ * with code that looks like this:
+ * ... Reader_monad.bind ...
+ * and the latter can be reformulated like this:
+ * let open Reader_monad in ... bind ...
+ * or equivalently, like this:
+ * Reader_monad.(... bind ...)
+ * Then you can use literally the same `... bind ...` code when writing instead:
+ * State_monad.(... bind ...)
+ *)
+
+(* That's great, however it still requires us to repeat the
+ * `... bind ...` code every time we want to change which monad we're working
+ * with. Shouldn't there be a way to _parameterize_ the `... bind ...` code
+ * on a monad, so that we only have to write the `... bind ...` code once,
+ * but can invoke it alternately with the Reader_monad supplied as an
+ * argument, or the State_monad, or another?
+ *
+ * There is a way to do this, but it requires putting the `... bind ...` code in
+ * its own module, and making that module parameterized on some M_monad
+ * module. Also we have to explicitly declare what commonality we're expecting
+ * from M_monad modules we're going to use as parameters. We'll explain how to
+ * do this in a moment.
+ *
+ * As preparation, a general observation:
+ * 'a and so on are type variables in OCaml; they stand for arbitrary types.
+ * What if you want a variable for a type constructor? For example, you want to
+ * generalize this pattern:
+ * type ('a) t1 = 'a -> ('a) list
+ * type ('a) t2 = 'a -> ('a) option
+ * type ('a) t3 = 'a -> ('a) reader
+ * and so on? OCaml won't let you do this:
+ * type ('a, 'b) t = 'a -> ('a) 'b
+ * To generalize on the 'b position, we instead have to use OCaml's modules,
+ * and in particular its ability to make modules parameterized on other modules
+ * (OCaml calls these parameterized modules Functors, but that name is also
+ * used in other ways in this literature, so I won't give in to it.)
+ *
+ * Here's how you'd have to define the t type from above:
+ * module T_maker(
+ * (* A sig...end block specifies the type of a module
+ * * What we're doing here is specifying the type of the
+ * * module parameter that will choose
+ * * whether b = list or b = option or b = reader...
+ * * This module parameter may supply values as well as types *)
+ * M : sig
+ * type ('a) b
+ * end
+ * ) =
+ * (* A struct...end block gives a module value
+ * * What we're doing here is building a new module that makes
+ * * use of the module that was supplied as M *)
+ * struct
+ * type ('a) t = 'a -> ('a) M.b
+ * end
+ * And here's how you'd use it:
+ * module T_list = T_maker(struct type 'a b = 'a list end);;
+ * type 'a t1 = 'a T_list.t;;
+ * module T_option = T_maker(struct type 'a b = 'a option end);;
+ * type 'a t2 = 'a T_option.t;;
+ * (* and so on *)
+ *
+ * I know, it seems unnecessarily complicated. Nonetheless, that's how it
+ * works. And that is also the technique we'll use to make our
+ * `... bind ...` code parametric on some M_monad module.
+ *)
+
+type 'a tree = Leaf of 'a | Node of ('a tree) * ('a tree);;
+
+let t1 = Node
+ (Node
+ (Leaf 2, Leaf 3),
+ Node
+ (Leaf 5,
+ Node
+ (Leaf 7, Leaf 11)));;
+
+
+module Tree_monadizer(M : sig
+ (* the module we're using as a parameter has to supply function values
+ * for unit and bind, as well as a monadic type constructor *)
+ type 'a m
+ val unit : 'a -> 'a m
+ val bind : 'a m -> ('a -> 'b m) -> 'b m
+end) = struct
+ let rec monadize (f: 'a -> 'b M.m) (t: 'a tree) : 'b tree M.m =
+ match t with
+ | Leaf a -> M.bind (f a) (fun b -> M.unit (Leaf b))
+ | Node(l, r) ->
+ M.bind (monadize f l) (fun l' ->
+ M.bind (monadize f r) (fun r' ->
+ M.unit (Node (l', r'))))
+end;;
+
+
+(* Now we supply Reader_monad as a parameter to Tree_monadizer.
+ * We'll get back a module TreeReader that contains a single value,
+ * the monadize function specialized to the Reader monad *)
+module TreeReader = Tree_monadizer(Reader_monad);;
+
+
+(* Make a TreeState module containing monadize specialized to the State monad *)
+module TreeState = Tree_monadizer(State_monad);;
+
+
+(* Make a TreeList module containing monadize specialized to the List monad *)
+module TreeList = Tree_monadizer(List_monad);;
+
+
+(* The Continuation monad is a bit more complicated *)
+module Continuation_monad = struct
+ type ('r,'a) m = ('a -> 'r) -> 'r;;
+ let unit a : ('r,'a) m = fun k -> k a;;
+ let bind (u: ('r,'a) m) (f: 'a -> ('r,'b) m) : ('r,'b) m =
+ fun k -> u (fun a -> f a k);;
+end
+
+(* Since the Continuation monad is parameterized on two types---it's
+ * ('r,'a) cont not ('a) cont---we can't match the type ('a) monad that
+ * Tree_monadizer expects in its parameter. So we have to make a different
+ * Tree_monadizer2 that takes a ('r,'a) monad type constructor in its
+ * parameter instead *)
+module Tree_monadizer2(M : sig
+ type ('r,'a) m
+ val unit : 'a -> ('r,'a) m
+ val bind : ('r,'a) m -> ('a -> ('r,'b) m) -> ('r,'b) m
+end) = struct
+ (* the body of the monadize function is the same; the only difference is in
+ * the types *)
+ let rec monadize (f: 'a -> ('r,'b) M.m) (t: 'a tree) : ('r,'b tree) M.m =
+ match t with
+ | Leaf a -> M.bind (f a) (fun b -> M.unit (Leaf b))
+ | Node(l, r) ->
+ M.bind (monadize f l) (fun l' ->
+ M.bind (monadize f r) (fun r' ->
+ M.unit (Node (l', r'))))
+end;;
+
+(* Make a TreeCont module containing monadize specialized to the Cont monad *)
+module TreeCont = Tree_monadizer2(Continuation_monad);;
+
+
+
+(*
+ * Here are all the examples from
+ * http://lambda.jimpryor.net/manipulating_trees_with_monads/
+ *)
+
+
+let asker : int -> int Reader_monad.m =
+ fun (a : int) -> fun (env : int -> int) -> env a;;
+
+(* asker takes an int and returns a Reader monad that
+ * "looks up" that int in the environment (i.e. modifies it)
+ * this is structurally parallel to the function `lookup` we used
+ * before to "look up" variables in the environment *)
+
+(* double each leaf *)
+let env = fun i -> i + i in
+TreeReader.monadize asker t1 env;;
+
+(* You can also avoid declaring a separate toplevel TreeReader module
+ * (or even a separate Reader_monad module) by using one of these forms:
+ * ...
+ * let module T = Tree_monadizer(Reader_monad) in
+ * T.monadize asker t1 env;;
+ * or:
+ * ...
+ * let env = fun i -> i + i in
+ * let module Monad = struct
+ * type env = int -> int;;
+ * type 'a m = env -> 'a;;
+ * let unit a : 'a m = fun e -> a;;
+ * let bind (u : 'a m) (f : 'a -> 'b m) : 'b m =
+ * fun e -> f (u e) e;;
+ * end in
+ * let module T = Tree_monadizer(Monad) in
+ * T.monadize asker t1 env;;
+ * or:
+ * ...
+ * let module T = Tree_monadizer(struct
+ * type env = int -> int;;
+ * type 'a m = env -> 'a;;
+ * let unit a : 'a m = fun e -> a;;
+ * let bind (u : 'a m) (f : 'a -> 'b m) : 'b m =
+ * fun e -> f (u e) e;;
+ * end) in
+ * T.monadize asker t1 env;;
+ *)
+
+
+(* square each leaf *)
+let env = fun i -> i * i in
+TreeReader.monadize asker t1 env;;
+
+
+
+(* count leaves *)
+
+let incrementer : int -> int State_monad.m =
+ fun (a : int) -> fun s -> (a, s+1);;
+(* incrementer takes an 'a and returns it wrapped in a
+ * State monad that increments the store *)
+
+let initial_store = 0 in
+TreeState.monadize incrementer t1 initial_store;;
+
+(* annotate leaves as they're visited *)
+
+let annotater : int -> (int * int) State_monad.m =
+ fun (a : int) -> fun s -> ((a,s+1), s+1);;
+
+let initial_store = 0 in
+TreeState.monadize annotater t1 initial_store;;
+
+
+(* copy tree with different choices for leaves *)
+
+let chooser i = if i = 2 then [20; 21] else [i];;
+
+TreeList.monadize chooser t1;;
+
+
+
+(* do nothing *)
+let initial_continuation = fun t -> t in
+TreeCont.monadize Continuation_monad.unit t1 initial_continuation;;
+
+(* convert tree to list of leaves *)
+let initial_continuation = fun t -> [] in
+TreeCont.monadize (fun a k -> a :: k a) t1 initial_continuation;;
+
+(* square each leaf using continuation *)
+let initial_continuation = fun t -> t in
+TreeCont.monadize (fun a k -> k (a*a)) t1 initial_continuation;;
+
+(* count leaves, using continuation *)
+let initial_continuation = fun t -> 0 in
+TreeCont.monadize (fun a k -> 1 + k a) t1 initial_continuation;;
+
+