* making their implementations private. The interpreter won't let
* let you freely interchange the `'a Reader_monad.m`s defined below
* with `Reader_monad.env -> 'a`. The code in this library can see that
- * those are equivalent, but code outside the library can't. Instead, you'll
+ * those are equivalent, but code outside the library can't. Instead, you'll
* have to use operations like `run` to convert the abstract monadic types
* to types whose internals you have free access to.
*
* derived from)
*)
-exception Undefined
(* Some library functions used below. *)
+
+exception Undefined
+
module Util = struct
let fold_right = List.fold_right
let map = List.map
let undef = Obj.magic (fun () -> raise Undefined)
end
-
-
(*
* This module contains factories that extend a base set of
* monadic definitions with a larger family of standard derived values.
*)
module Monad = struct
+
(*
* Signature extenders:
* Make :: BASE -> S
* (Catch) plus (unit a) v === unit a
* (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
* When no natural zero is available, use `let zero () = Util.undef`.
- * The Make functor automatically detects for zero >>= ..., and
+ * The Make functor automatically detects for zero >>= ..., and
* plus zero _, plus _ zero; it also substitutes zero for pattern-match failures.
*)
val zero : unit -> ('x,'a) m
(* note that second argument is an 'a list, not the more abstract 'a m *)
(* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
-(* TODO
- val permute : 'a m -> 'a m m
- val select : 'a m -> ('a * 'a m) m
-*)
+ val permute : ('x,'a) m -> ('x,('x,'a) m) m
+ val select : ('x,'a) m -> ('x,('a * ('x,'a) m)) m
val expose : ('x,'a) m -> ('x,'a list) Wrapped.m
end
end = struct
| [] -> zero ()
| x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
module T(Wrapped : Monad.S) = struct
- (* Wrapped.sequence ms ===
+ (* Wrapped.sequence ms ===
let plus1 u v =
Wrapped.bind u (fun x ->
Wrapped.bind v (fun xs ->
Wrapped.bind v (fun vs ->
Wrapped.unit (Base.plus us vs)))
end)
-(*
- let permute : 'a m -> 'a m m
- let select : 'a m -> ('a * 'a m) m
-*)
+
+ (* insert 3 {[1;2]} ~~> {[ {[3;1;2]}; {[1;3;2]}; {[1;2;3]} ]} *)
+ let rec insert a u =
+ plus
+ (unit (Wrapped.bind u (fun us -> Wrapped.unit (a :: us))))
+ (Wrapped.bind u (fun us -> match us with
+ | [] -> zero ()
+ | x::xs -> (insert a (Wrapped.unit xs)) >>= fun v -> unit (Wrapped.bind v (fun vs -> Wrapped.unit (x :: vs)))))
+
+ (* select {[1;2;3]} ~~> {[ (1,{[2;3]}); (2,{[1;3]}), (3;{[1;2]}) ]} *)
+ let rec select u =
+ Wrapped.bind u (fun us -> match us with
+ | [] -> zero ()
+ | x::xs -> plus (unit (x, Wrapped.unit xs))
+ (select (Wrapped.unit xs) >>= fun (x', xs') -> unit (x', Wrapped.bind xs' (fun ys -> Wrapped.unit (x :: ys)))))
+
+ (* permute {[1;2;3]} ~~> {[ {[1;2;3]}; {[2;1;3]}; {[2;3;1]}; {[1;3;2]}; {[3;1;2]}; {[3;2;1]} ]} *)
+
+ let rec permute u =
+ Wrapped.bind u (fun us -> match us with
+ | [] -> unit (zero ())
+ | x::xs -> permute (Wrapped.unit xs) >>= (fun v -> insert x v))
+
let expose u = u
end
end
let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
let expose u = u
end
+
end;;