* have to use operations like `run` to convert the abstract monadic types
* to types whose internals you have free access to.
*
+ * Acknowledgements: This is largely based on the mtl library distributed
+ * 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/>
+ * - Ken Shan "Monads for natural language semantics" <http://arxiv.org/abs/cs/0205026v1>
+ * - 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 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 run_exn u =
if u == Util.undef then raise Undefined else B.run_exn u
let (>>=) = bind
+ (* expressions after >> will be evaluated before they're passed to
+ * bind, so you can't do `zero () >> assert false`
+ * this works though: `zero () >>= fun _ -> assert false`
+ *)
let (>>) u v = u >>= fun _ -> v
let lift f u = u >>= fun a -> unit (f a)
(* lift is called listM, fmap, and <$> in Haskell *)
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
- (* not in tail position, will Stack overflow *)
+ (* A Haskell-like version works:
+ let rec forever uthunk = uthunk () >>= fun _ -> forever uthunk
+ * but the recursive call is not in tail position so this can stack overflow. *)
let forever uthunk =
- let rec loop () = uthunk () >>= fun _ -> loop ()
- in loop ()
+ let z = zero () in
+ let id result = result in
+ 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 [])
| Success a -> a
| Error e -> raise (Err.Exc e)
let zero () = Util.undef
- let plus u v = u
- (*
- let zero () = Error Err.zero
- let plus u v = match (u, v) with
- | Success _, _ -> u
- (* to satisfy (Catch) laws, plus u zero = u, even if u = Error _
- * otherwise, plus (Error _) v = v *)
- | Error _, _ when v = zero -> u
- (* combine errors *)
- | Error e1, Error e2 when u <> zero -> Error (Err.plus e1 e2)
- | Error _, _ -> v
- *)
+ (* satisfies Catch *)
+ let plus u v = match u with
+ | Success _ -> u
+ | Error _ -> if v == Util.undef then u else v
end
include Monad.Make(Base)
(* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
| Error e -> raise (Err.Exc e))
in Wrapped.run_exn w
let plus u v = Wrapped.plus u v
- let zero () = elevate (Wrapped.zero ())
+ let zero () = Wrapped.zero () (* elevate (Wrapped.zero ()) *)
end)
let throw e = Wrapped.unit (Error e)
let catch u handler = Wrapped.bind u (fun t -> match t with
*)
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
type ('x,'a) result = env -> ('x,'a) Wrapped.result
type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
let elevate w = fun e -> w
- let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
+ let bind u f = fun e -> Wrapped.bind (u e) (fun a -> f a e)
let run u = fun e -> Wrapped.run (u e)
let run_exn u = fun e -> Wrapped.run_exn (u e)
(* satisfies Distrib *)
- let plus u v = fun s -> Wrapped.plus (u s) (v s)
- let zero () = elevate (Wrapped.zero ())
+ let plus u v = fun e -> Wrapped.plus (u e) (v e)
+ let zero () = fun e -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
end
include Monad.MakeT(BaseT)
- let ask = fun e -> Wrapped.unit e
+ let ask = Wrapped.unit
let local modifier u = fun e -> u (modifier e)
let asks selector = ask >>= (fun e ->
try unit (selector e)
in Wrapped.run_exn w
(* satisfies Distrib *)
let plus u v = fun s -> Wrapped.plus (u s) (v s)
- let zero () = elevate (Wrapped.zero ())
+ let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
end
include Monad.MakeT(BaseT)
let get = fun s -> Wrapped.unit (s, s)
end
end
+
(* State monad with different interface (structured store) *)
module Ref_monad(V : sig
type value
in Wrapped.run_exn w
(* satisfies Distrib *)
let plus u v = fun s -> Wrapped.plus (u s) (v s)
- let zero () = elevate (Wrapped.zero ())
+ let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
end
include Monad.MakeT(BaseT)
let newref value = fun s -> Wrapped.unit (alloc value s)
end
end
-(* TODO needs a T *)
+
(* must be parameterized on (struct type log = ... end) *)
module Writer_monad(Log : sig
type log
val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
(* val pass : ('x,'a * (log -> log)) m -> ('x,'a) m *)
val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
+ (* WriterT transformer *)
+ module T : functor (Wrapped : Monad.S) -> sig
+ type ('x,'a) result = ('x,'a * log) Wrapped.result
+ type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
+ val tell : log -> ('x,unit) m
+ val listen : ('x,'a) m -> ('x,'a * log) m
+ val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
+ val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
+ end
end = struct
type log = Log.log
module Base = struct
type ('x,'a) result = 'a * log
type ('x,'a) result_exn = 'a * log
let unit a = (a, Log.zero)
- let bind (a, w) f = let (a', w') = f a in (a', Log.plus w w')
+ let bind (a, w) f = let (b, w') = f a in (b, Log.plus w w')
let run u = u
let run_exn = run
let zero () = Util.undef
let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
let censor f u = pass (u >>= fun a -> unit (a, f))
+ module T(Wrapped : Monad.S) = struct
+ module BaseT = struct
+ module Wrapped = Wrapped
+ type ('x,'a) m = ('x,'a * log) Wrapped.m
+ type ('x,'a) result = ('x,'a * log) Wrapped.result
+ type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
+ let elevate w =
+ Wrapped.bind w (fun a -> Wrapped.unit (a, Log.zero))
+ let bind u f =
+ Wrapped.bind u (fun (a, w) ->
+ Wrapped.bind (f a) (fun (b, w') ->
+ Wrapped.unit (b, Log.plus w w')))
+ let zero () = elevate (Wrapped.zero ())
+ let plus u v = Wrapped.plus u v
+ let run u = Wrapped.run u
+ let run_exn u = Wrapped.run_exn u
+ end
+ include Monad.MakeT(BaseT)
+ let tell entries = Wrapped.unit ((), entries)
+ let listen u = Wrapped.bind u (fun (a, w) -> Wrapped.unit ((a, w), w))
+ let pass u = Wrapped.bind u (fun ((a, f), w) -> Wrapped.unit (a, f w))
+ (* rest are derived in same way as before *)
+ let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w)
+ let censor f u = pass (u >>= fun a -> unit (a, f))
+ end
end
(* pre-define simple Writer *)
end
-(* TODO needs a T *)
module Continuation_monad : sig
(* expose only the implementation of type `('r,'a) result` *)
type ('r,'a) m
(* val abort : ('a,'a) m -> ('a,'b) m *)
val abort : 'a -> ('a,'b) m
val run0 : ('a,'a) m -> 'a
+ (* ContinuationT transformer *)
+ module T : functor (Wrapped : Monad.S) -> sig
+ type ('r,'a) m
+ type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
+ type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
+ include Monad.S 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
+ val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
+ val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
+ (* TODO: reset,shift,abort,run0 *)
+ end
end = struct
let id = fun i -> i
module Base = struct
(* let abort a = shift (fun _ -> a) *)
let abort a = shift (fun _ -> unit a)
let run0 (u : ('a,'a) m) = (u) id
+ module T(Wrapped : Monad.S) = struct
+ module BaseT = struct
+ module Wrapped = Wrapped
+ type ('r,'a) m = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.m
+ type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
+ type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
+ let elevate w = fun k -> Wrapped.bind w k
+ let bind u f = fun k -> u (fun a -> f a k)
+ let run u k = Wrapped.run (u k)
+ let run_exn u k = Wrapped.run_exn (u k)
+ let zero () = Util.undef
+ let plus u v = u
+ end
+ include Monad.MakeT(BaseT)
+ let callcc f = (fun k ->
+ let usek a = (fun _ -> k a)
+ in (f usek) k)
+ end
end
*)
-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
include BaseT
let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
end
-end
+end;;
-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 LR = L.T(R);;
-module LS = L.T(S);;
-module TL = T.T(L);;
-module TR = T.T(R);;
-module TS = T.T(S);;
-module C = Continuation_monad
-module TC = T.T(C);;
+module C = Continuation_monad;;
-print_endline "=== test Leaf(...).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))));;
-
-let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
-TS.run ts 0;;
-(*
-- : int T.tree option * S.store =
-(Some
- (T.Node
- (T.Node (T.Leaf 2, T.Leaf 3),
- T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11)))),
- 5)
-*)
-
-let ts2 = TS.distribute (fun i -> S.(puts succ >> get >>= fun n -> unit (i,n))) t1;;
-TS.run_exn ts2 0;;
-(*
-- : (int * S.store) T.tree option * S.store =
-(Some
- (T.Node
- (T.Node (T.Leaf (2, 1), T.Leaf (3, 2)),
- T.Node (T.Leaf (5, 3), T.Node (T.Leaf (7, 4), T.Leaf (11, 5))))),
- 5)
-*)
-
-let tr = TR.distribute (fun i -> R.asks (fun e -> e i)) t1;;
-TR.run_exn tr (fun i -> i+i);;
-(*
-- : int T.tree option =
-Some
- (T.Node
- (T.Node (T.Leaf 4, T.Leaf 6),
- T.Node (T.Leaf 10, T.Node (T.Leaf 14, T.Leaf 22))))
-*)
-
-let tl = TL.distribute (fun i -> L.(unit (i,i+1))) t1;;
-TL.run_exn tl;;
-(*
-- : (int * int) TL.result =
-[Some
- (T.Node
- (T.Node (T.Leaf (2, 3), T.Leaf (3, 4)),
- T.Node (T.Leaf (5, 6), T.Node (T.Leaf (7, 8), T.Leaf (11, 12)))))]
-*)
-
-let l2 = [1;2;3;4;5];;
-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))));;
-
-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);;
-(* int list = [10; 11; 20; 21; 30; 31; 40; 41; 50; 51] *)
-
-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);;
-(*
-int T.tree option =
-Some
- (T.Node
- (T.Node (T.Leaf 10, T.Leaf 11),
- T.Node
- (T.Node
- (T.Node (T.Node (T.Leaf 20, T.Leaf 21), T.Node (T.Leaf 30, T.Leaf 31)),
- T.Node (T.Leaf 40, T.Leaf 41)),
- T.Node (T.Leaf 50, T.Leaf 51))))
- *)
-
-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;;
-(*
-- : 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
((111,0), (0,0));;
(example ~+10, example ~-10);;
-let testc df ic =
- C.run_exn TC.(run (distribute df t1)) ic;;
-
-
-(*
-(* do nothing *)
-let initial_continuation = fun t -> t in
-TreeCont.monadize t1 Continuation_monad.unit initial_continuation;;
-*)
-testc (C.unit) id;;
-
-(*
-(* count leaves, using continuation *)
-let initial_continuation = fun t -> 0 in
-TreeCont.monadize t1 (fun a k -> 1 + k a) initial_continuation;;
-*)
-
-testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (1 + v))) (fun t -> 0);;
-
-(*
-(* convert tree to list of leaves *)
-let initial_continuation = fun t -> [] in
-TreeCont.monadize t1 (fun a k -> a :: k a) initial_continuation;;
-*)
-
-testc C.(fun a -> shift (fun k -> k a >>= fun v -> unit (a::v))) (fun t -> ([] : int list));;
-
-(*
-(* square each leaf using continuation *)
-let initial_continuation = fun t -> t in
-TreeCont.monadize t1 (fun a k -> k (a*a)) initial_continuation;;
-*)
-
-testc C.(fun a -> shift (fun k -> k (a*a))) (fun t -> t);;
-
-
-(*
-(* replace leaves with list, using continuation *)
-let initial_continuation = fun t -> t in
-TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
-*)
-
-testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;
print_endline "=== pa_monad's Continuation Tests ============";;