From: Jim Pryor Date: Sun, 12 Dec 2010 03:26:16 +0000 (-0500) Subject: tweak monads-lib X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=commitdiff_plain;h=092c31a2cad42975fb4751c2eda5ac03a13c8cd5 tweak monads-lib Signed-off-by: Jim Pryor --- diff --git a/code/monads.ml b/code/monads.ml index 34ad1cef..bdc3eba2 100644 --- a/code/monads.ml +++ b/code/monads.ml @@ -42,6 +42,16 @@ * 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 Glaskow 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: + * - + * - Ken Shan "Monads for natural language semantics" + * - 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). *) exception Undefined @@ -140,6 +150,10 @@ module Monad = struct 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 *) @@ -155,10 +169,20 @@ module Monad = struct 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: + let rec forever uthunk = uthunk () >>= fun _ -> forever uthunk + * is not in tail position and will stack overflow. *) let forever uthunk = - let rec loop () = uthunk () >>= fun _ -> loop () + 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 sequence ms = let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in Util.fold_right op ms (unit []) @@ -389,6 +413,13 @@ end = struct 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 @@ -432,18 +463,10 @@ end = struct | 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) *) @@ -472,7 +495,7 @@ end = struct | 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 @@ -557,15 +580,15 @@ end = struct 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) @@ -630,7 +653,7 @@ end = struct 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) @@ -709,7 +732,7 @@ end = struct 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) @@ -718,7 +741,7 @@ end = struct end end -(* TODO needs a T *) + (* must be parameterized on (struct type log = ... end) *) module Writer_monad(Log : sig type log @@ -735,6 +758,17 @@ end) : sig 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 @@ -742,7 +776,7 @@ end = 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 @@ -754,6 +788,31 @@ end = struct 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 *) @@ -812,7 +871,6 @@ end = struct end -(* TODO needs a T *) module Continuation_monad : sig (* expose only the implementation of type `('r,'a) result` *) type ('r,'a) m @@ -825,6 +883,16 @@ module Continuation_monad : sig (* 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 @@ -863,6 +931,24 @@ end = 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