add writer monad

diff --git a/debugger/OMakefile b/debugger/OMakefile
index d696069..62b1a65 100644 (file)
--- a/debugger/OMakefile
+++ b/debugger/OMakefile
@@ -7,7 +7,7 @@ OCAMLPACKS[] =
 FILES[] =
        socket
 
-UseCamlp4(pa_openin pa_oo pa_field)
+UseCamlp4(pa_openin pa_oo pa_field pa_monad)
 PROGRAM=../debugger
 
 OCAMLINCLUDES += $(ROOT)/base

diff --git a/debugger/writer.ml b/debugger/writer.ml
index 23b0226..d51700f 100644 (file)
--- a/debugger/writer.ml
+++ b/debugger/writer.ml
@@ -1,4 +1,31 @@
 open Base
 
-let db n xs = xs @ [(string_of_char @@ Char.chr n)]
-let (+>>) _ _ = assert false
+module type Monoid = sig
+  type 'a t
+  val mempty : 'a t
+  val mappend : 'a t -> 'a t -> 'a t
+end
+
+module Make = functor (W : Monoid) ->
+  struct
+    type ('a, 'b) m = 'a * 'b W.t
+
+    let ret a =
+      (a, W.mempty)
+
+    let bind (a,w) f =
+      let (a', w') = f a in
+       (a', W.mappend w w')
+
+    let pass ((a, f), w) =
+      (a, f w)
+
+    let listen (a, w) =
+      ((a,w), w)
+
+    let tell s =
+      ((), s)
+
+    let runWriter =
+      id
+  end

diff --git a/debugger/writer.mli b/debugger/writer.mli
index f668ccf..7d7b28e 100644 (file)
--- a/debugger/writer.mli
+++ b/debugger/writer.mli
@@ -1,2 +1,18 @@
-val db : int -> string list -> string list
-val (+>>) : ('a -> 'b) -> ('c -> 'a) -> 'b
+module type Monoid = sig
+  type 'a t
+  val mempty : 'a t
+  val mappend : 'a t -> 'a t -> 'a t
+end
+
+module Make : functor(W: Monoid) -> sig
+  type ('a,'b) m
+
+  val bind : ('a, 'b) m -> ('a -> ('c, 'b) m) -> ('c, 'b) m
+  val ret  : 'a -> ('a, 'b) m
+
+  val pass : (('a * ('b W.t -> 'b W.t)), 'b) m -> ('a,'b) m
+  val listen : ('a,'b) m -> ('a * 'b W.t, 'b) m
+  val tell   : 'b W.t -> (unit,'b) m
+
+  val runWriter : ('a,'b) m -> ('a * 'b W.t)
+end

diff --git a/debugger/writerTest.ml b/debugger/writerTest.ml
index a0f7a2b..d24b071 100644 (file)
--- a/debugger/writerTest.ml
+++ b/debugger/writerTest.ml
@@ -1,14 +1,42 @@
 open Base
 open OUnit
-open Writer
+
+module ListMonoid = struct
+  type 'a t = 'a list
+  let mempty = []
+  let mappend = (@)
+end
+
+module StrMonoid = struct
+  type 'a t = string
+  let mempty = ""
+  let mappend = (^)
+end
+
+module W = Writer.Make(ListMonoid)
+module W2 = Writer.Make(StrMonoid)
+open W
 
 let _ = begin "writer.ml" >::: [
-  "combinator" >:: begin fun () ->
-    let data =
-      db 42
-      +>> db 10 in
-      assert_equal "\042\010" @@ String.concat "" (data [])
+  "tell" >:: begin fun () ->
+    let m =
+      perform with module W in begin
+        tell ["hi"];
+       tell ["ho"];
+       ret ()
+      end in
+    assert_equal () @@ fst @@ runWriter m;
+    assert_equal ["hi"; "ho"] @@ snd @@ runWriter m
+  end;
+  "with_str" >:: begin fun () ->
+    open W2 in
+    let m =
+      perform with module W2 in begin
+        tell "hi";
+       tell "ho";
+       ret ()
+      end in
+    assert_equal () @@ fst @@ runWriter m;
+    assert_equal "hiho" @@ snd @@ runWriter m
   end
 ] end +> run_test_tt_main
-
-