* to types whose internals you have free access to.
*
* Acknowledgements: This is largely based on the mtl library distributed
- * with the Glaskow Haskell Compiler. I've also been helped in
+ * with the Glasgow Haskell Compiler. I've also been helped in
* various ways by posts and direct feedback from Oleg Kiselyov and
* Chung-chieh Shan. The following were also useful:
* - <http://pauillac.inria.fr/~xleroy/mpri/progfunc/>
* - http://www.grabmueller.de/martin/www/pub/Transformers.pdf
* - http://en.wikibooks.org/wiki/Haskell/Monad_transformers
*
- * Licensing: MIT (if that's compatible with the ghc sources).
+ * Licensing: MIT (if that's compatible with the ghc sources this is partly
+ * derived from)
*)
exception Undefined
in loop len []
(* Dirty hack to be a default polymorphic zero.
* To implement this cleanly, monads without a natural zero
- * should always wrap themselves in an option layer (see Leaf_monad). *)
+ * should always wrap themselves in an option layer (see Tree_monad). *)
let undef = Obj.magic (fun () -> raise Undefined)
end
let (>=>) f g = fun a -> f a >>= g
let do_when test u = if test then u else unit ()
let do_unless test u = if test then unit () else u
- (* A Haskell-like version:
+ (* A Haskell-like version works:
let rec forever uthunk = uthunk () >>= fun _ -> forever uthunk
- * is not in tail position and will stack overflow. *)
+ * but the recursive call is not in tail position so this can stack overflow. *)
let forever uthunk =
let z = zero () in
let id result = result in
- let newk = ref id in
- let rec loop () =
- let result = uthunk (newk := id) >>= chained
- in !newk result
- and chained =
- fun _ -> newk := (fun _ -> loop ()); z (* we use z only for its polymorphism *)
- in loop ()
- (* reimplementations of the preceding using a hand-rolled State or StateT also stack overflowed *)
+ let kcell = ref id in
+ let rec loop _ =
+ let result = uthunk (kcell := id) >>= chained
+ in !kcell result
+ and chained _ =
+ kcell := loop; z (* we use z only for its polymorphism *)
+ in loop z
+ (* Reimplementations of the preceding using a hand-rolled State or StateT
+can also stack overflow. *)
let sequence ms =
let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
Util.fold_right op ms (unit [])
end
end
-(*
-# LL.(run(plus (unit 1) (unit 2) >>= fun i -> plus (unit i) (unit(10*i)) ));;
-- : ('_a, int) LL.result = [[1; 10; 2; 20]]
-# LL.(run(plus (unit 1) (unit 2) >>= fun i -> elevate L.(plus (unit i) (unit(10*i)) )));;
-- : ('_a, int) LL.result = [[1; 2]; [1; 20]; [10; 2]; [10; 20]]
-*)
-
(* must be parameterized on (struct type err = ... end) *)
module Error_monad(Err : sig
*)
end)
-(*
-# EL.(run( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
-- : int EL.result = [Failure.Error "bye"; Failure.Success 30]
-# LE.(run( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
-- : int LE.result = Failure.Error "bye"
-# EL.(run_exn( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
-Exception: Failure "bye".
-# LE.(run_exn( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
-Exception: Failure "bye".
-
-# ES.(run( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
-- : int Failure.error * S.store = (Failure.Error "bye", 1)
-# SE.(run( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
-- : (int * S.store) Failure.result = Failure.Error "bye"
-# ES.(run_exn( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
-Exception: Failure "bye".
-# SE.(run_exn( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
-Exception: Failure "bye".
- *)
-
(* must be parameterized on (struct type env = ... end) *)
module Reader_monad(Env : sig type env end) : sig
end
end
+
(* State monad with different interface (structured store) *)
module Ref_monad(V : sig
type value
*)
-module Leaf_monad : sig
+module Tree_monad : sig
(* We implement the type as `'a tree option` because it has a natural`plus`,
* and the rest of the library expects that `plus` and `zero` will come together. *)
type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
type ('x,'a) result = 'a tree option
type ('x,'a) result_exn = 'a tree
include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
- (* LeafT transformer *)
+ (* TreeT transformer *)
module T : functor (Wrapped : Monad.S) -> sig
type ('x,'a) result = ('x,'a tree option) Wrapped.result
type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
module L = List_monad;;
module R = Reader_monad(struct type env = int -> int end);;
module S = State_monad(struct type store = int end);;
-module T = Leaf_monad;;
+module T = Tree_monad;;
module LR = L.T(R);;
module LS = L.T(S);;
module TL = T.T(L);;
module TC = T.T(C);;
-print_endline "=== test Leaf(...).distribute ==================";;
+print_endline "=== test TreeT(...).distribute ==================";;
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))));;
- : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
*)
-print_endline "=== test Leaf(Continuation).distribute ==================";;
+print_endline "=== test TreeT(Continuation).distribute ==================";;
let id : 'z. 'z -> 'z = fun x -> x