code/tree_monadize.ml

   1 (*
   2  * tree_monadize.ml
   3  *
   4  * 'a and so on are type variables in OCaml; they stand for arbitrary types.
   5  * What if you want a variable for a type constructor? For example, you want to
   6  * generalize this pattern:
   7  *      type ('a) t1 = 'a -> ('a) list
   8  *      type ('a) t2 = 'a -> ('a) option
   9  *      type ('a) t3 = 'a -> ('a) reader
  10  * and so on? OCaml won't let you do this:
  11  *      type ('a, 'b) t = 'a -> ('a) 'b
  12  * To generalize on the 'b position, we instead have to use OCaml's modules,
  13  * and in particular its ability to make modules parameterized on other modules
  14  * (OCaml calls these parameterized modules Functors, but that name is also
  15  * used in other ways in this literature, so I won't give in to it.)
  16  *
  17  * Here's how you'd have to define the t type from above:
  18  *      module T_maker(
  19  *      (* A sig...end block specifies the type of a module
  20  *       * What we're doing here is specifying the type of the
  21          * module parameter that will choose
  22          * whether b = list or b = option or b = reader...
  23          * This module parameter may supply values as well as types *)
  24  *      Parm: sig
  25  *          type ('a) b
  26  *      end
  27  *      ) =
  28  *      (* A struct...end block gives a module value
  29          * What we're doing here is building a new module that makes
  30          * use of the module that was supplied as Parm *)
  31  *      struct
  32  *          type ('a) t = 'a -> ('a) Parm.b
  33  *      end
  34  * And here's how you'd use it:
  35  *      module T_list = T_maker(struct type 'a b = 'a list end);;
  36  *      type 'a t1 = 'a T_list.t;;
  37  *      module T_option = T_maker(struct type 'a b = 'a option end);;
  38  *      type 'a t2 = 'a T_option.t;;
  39  *      (* and so on *)
  40  *
  41  * I know, it seems unnecessarily complicated.
  42  *)
  43
  44 type 'a tree = Leaf of 'a | Node of ('a tree) * ('a tree);;
  45
  46 let t1 = Node
  47            (Node
  48              (Leaf 2, Leaf 3),
  49             Node
  50              (Leaf 5,
  51               Node
  52                 (Leaf 7, Leaf 11)));;
  53
  54
  55 module Tree_monadizer(Parm : sig
  56   (* the module we're using as a parameter has to supply function values
  57    * for unit and bind, as well as a monadic type constructor m *)
  58   type 'a m
  59   val unit : 'a -> 'a m
  60   val bind : 'a m -> ('a -> 'b m) -> 'b m
  61 end) = struct
  62   let rec monadize (f: 'a -> 'b Parm.m) (t: 'a tree) : 'b tree Parm.m =
  63     match t with
  64     | Leaf a -> Parm.bind (f a) (fun b -> Parm.unit (Leaf b))
  65     | Node(l, r) ->
  66         Parm.bind (monadize f l) (fun l' ->
  67           Parm.bind (monadize f r) (fun r' ->
  68             Parm.unit (Node (l', r'))))
  69 end;;
  70
  71
  72 type env = int -> int;;
  73
  74 type 'a reader = env -> 'a;;
  75 let unit_reader a : 'a reader = fun e -> a;;
  76 let bind_reader (u : 'a reader) (f : 'a -> 'b reader) : 'b reader =
  77   fun e -> f (u e) e;;
  78
  79 (* Now we supply the Reader monad as a parameter to Tree_monadizer.
  80  * We'll get back a module TreeReader that contains a single value,
  81  * the monadize function specialized to the Reader monad *)
  82 module TreeReader = Tree_monadizer(struct
  83   type 'a m = 'a reader
  84   let unit = unit_reader
  85   let bind = bind_reader
  86 end);;
  87
  88
  89 type store = int;;
  90
  91 type 'a state = store -> 'a * store;;
  92 let unit_state a : 'a state  = fun s -> (a, s);;
  93 let bind_state (u : 'a state) (f : 'a -> 'b state) : 'b state =
  94   fun s -> (let (a, s') = u s in (f a) s');;
  95
  96 (* Make a TreeState module containing monadize specialized to the State monad *)
  97 module TreeState =  Tree_monadizer(struct
  98   type 'a m = 'a state
  99   let unit = unit_state
 100   let bind = bind_state
 101 end);;
 102
 103
 104 let unit_list a = [a];;
 105 let bind_list (u: 'a list) (f : 'a -> 'b list) : 'b list =
 106   List.concat(List.map f u);;
 107
 108 (* Make a TreeList module containing monadize specialized to the List monad *)
 109 module TreeList =  Tree_monadizer(struct
 110   type 'a m = 'a list
 111   let unit = unit_list
 112   let bind = bind_list
 113 end);;
 114
 115
 116 (* since the Continuation monad is parameterized on two types---it's
 117  * ('a,'r) cont not ('a) cont---we can't match the type ('a) m that
 118  * Tree_monadizer expects in its parameter. So we have to make a different
 119  * Tree_monadizer2 that takes a ('a,'x) m type constructor in its
 120  * parameter instead *)
 121 module Tree_monadizer2(Parm : sig
 122   type ('a,'x) m
 123   val unit : 'a -> ('a,'x) m
 124   val bind : ('a,'x) m -> ('a -> ('b,'x) m) -> ('b,'x) m
 125 end) = struct
 126   (* the body of the monadize function is the same; the only difference is in
 127    * the types *)
 128   let rec monadize (f: 'a -> ('b,'x) Parm.m) (t: 'a tree) : ('b tree,'x) Parm.m =
 129     match t with
 130     | Leaf a -> Parm.bind (f a) (fun b -> Parm.unit (Leaf b))
 131     | Node(l, r) ->
 132         Parm.bind (monadize f l) (fun l' ->
 133           Parm.bind (monadize f r) (fun r' ->
 134             Parm.unit (Node (l', r'))))
 135 end;;
 136
 137 type ('a,'r) cont = ('a -> 'r) -> 'r;;
 138 let unit_cont a : ('a,'r) cont = fun k -> k a;;
 139 let bind_cont (u: ('a,'r) cont) (f: 'a -> ('b,'r) cont) : ('b,'r) cont =
 140   fun k -> u (fun a -> f a k);;
 141
 142 (* Make a TreeCont module containing monadize specialized to the Cont monad *)
 143 module TreeCont =  Tree_monadizer2(struct
 144   type ('a,'r) m = ('a,'r) cont
 145   let unit = unit_cont
 146   let bind = bind_cont
 147 end);;
 148
 149
 150
 151 (*
 152  * Here are all the examples from
 153  * http://lambda.jimpryor.net/manipulating_trees_with_monads/
 154  *)
 155
 156
 157 let int_readerize : int -> int reader =
 158   fun (a : int) -> fun (env : int -> int) -> env a;;
 159
 160 (* int_readerize takes an int and returns a Reader monad that
 161  * "looks up" that int in the environment (i.e. modifies it)
 162  * this is structurally parallel to the function `lookup` we used
 163  * before to "look up" variables in the environment *)
 164
 165 (* double each leaf *)
 166 let env = fun i -> i + i in
 167 TreeReader.monadize int_readerize t1 env;;
 168
 169 (* square each leaf *)
 170 let env = fun i -> i * i in
 171 TreeReader.monadize int_readerize t1 env;;
 172
 173
 174
 175 let incrementer : int -> int state =
 176   fun (a : int) -> fun s -> (a, s+1);;
 177
 178 (* incrementer takes an 'a and returns it wrapped in a
 179  * State monad that increments the store *)
 180
 181 (* count leaves *)
 182 let initial_store = 0 in
 183 TreeState.monadize incrementer t1 initial_store;;
 184
 185
 186
 187 (* replace leaves with list *)
 188 TreeList.monadize (fun i -> [ [i;i*i] ]) t1;;
 189
 190
 191
 192 (* do nothing *)
 193 let initial_continuation = fun t -> t in
 194 TreeCont.monadize unit_cont t1 initial_continuation;;
 195
 196 (* convert tree to list of leaves *)
 197 let initial_continuation = fun t -> [] in
 198 TreeCont.monadize (fun a k -> a :: k a) t1 initial_continuation;;
 199
 200 (* square each leaf using continuation *)
 201 let initial_continuation = fun t -> t in
 202 TreeCont.monadize (fun a k -> k (a*a)) t1 initial_continuation;;
 203
 204 (* replace leaves with list, using continuation *)
 205 let initial_continuation = fun t -> t in
 206 TreeCont.monadize (fun a k -> k [a; a*a]) t1 initial_continuation;;
 207
 208 (* count leaves, using continuation *)
 209 let initial_continuation = fun t -> 0 in
 210 TreeCont.monadize (fun a k -> 1 + k a) t1 initial_continuation;;
 211
 212