X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=blobdiff_plain;f=code%2Fmonads.ml;h=b678a92c28a75c78e257e55a9979268477b09e3e;hp=bdc3eba2adc8982c64716d7a8a9e03b36c664e68;hb=6620761d57706f681ccf431c19d6d6fd77fa2942;hpb=092c31a2cad42975fb4751c2eda5ac03a13c8cd5 diff --git a/code/monads.ml b/code/monads.ml index bdc3eba2..b678a92c 100644 --- a/code/monads.ml +++ b/code/monads.ml @@ -43,7 +43,7 @@ * 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: * - @@ -51,7 +51,8 @@ * - 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 @@ -73,7 +74,7 @@ module Util = struct 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 @@ -169,20 +170,21 @@ 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 - (* 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 []) @@ -413,13 +415,6 @@ 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 @@ -514,26 +509,6 @@ module Failure = Error_monad(struct *) 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 @@ -665,6 +640,7 @@ end = struct end end + (* State monad with different interface (structured store) *) module Ref_monad(V : sig type value @@ -1012,14 +988,14 @@ 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 @@ -1093,7 +1069,7 @@ 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 T = Tree_monad;; module LR = L.T(R);; module LS = L.T(S);; module TL = T.T(L);; @@ -1103,7 +1079,7 @@ module C = Continuation_monad 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))));; @@ -1173,7 +1149,7 @@ LS.run (LS.distribute (fun i -> if i = -1 then S.get else if i < 0 then S.(puts - : 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