Lemonade 0.5.0

.travis.yml

@@ -5,6 +5,7 @@ addons:
     sources:
     - avsm
     packages:
+    - aspcud
     - ocaml
     - opam
     - ocaml-native-compilers

Makefile

@@ -12,7 +12,7 @@
 # http://www.cecill.info/licences/Licence_CeCILL-B_V1-en.txt
 
 PACKAGE=		lemonade
-VERSION=		0.4.0
+VERSION=		0.5.0
 OFFICER=		[email protected]
 
 .sinclude "Makefile.config"

opam/opam

@@ -1,7 +1,7 @@
 opam-version: "1.2"
 maintainer: "[email protected]"
 authors: "Michael Grünewald"
-version: "0.4.0"
+version: "0.5.0"
 license: "CeCILL-B"
 homepage: "https://github.com/michipili/lemonade"
 bug-reports: "https://github.com/michipili/lemonade/issues"

ppx/ppx_lemonade.ml

@@ -271,10 +271,6 @@ let lemonade_mapper argv =
   let super = default_mapper in
   let expr this e =
     match e with
-    | [%expr [%e? lhs] >> [%e? rhs]] ->
-        let pat = [%pat? _]in
-        let lhs, rhs = this.expr this lhs, this.expr this rhs in
-        [%expr Lwt.bind [%e lhs] (fun [%p pat] -> [%e rhs])]
     | { pexp_desc = Pexp_extension ({ txt = id; loc }, PStr [{ pstr_desc = Pstr_eval (exp, attr) }]) } ->
         (match lemonade_extension ~loc id with
          | Some(monad) -> lemonade_expression this monad exp attr

src/lemonade_Reader.mli

@@ -61,6 +61,7 @@ sig
     (** The type of consumed data. *)
 
     include Lemonade_Type.S
+      with type 'a t = 'a M.t t
 
     val read : environment t
     (** Access the current environment. *)

src/lemonade_Stream.ml

@@ -238,7 +238,12 @@ struct
         | None -> Monad.return true)
 
   let map f m =
-    from (fun _ -> peek m >|= (function Some a -> Some (f a) | None -> None))
+    let f _ =
+      peek m >>= function
+      | Some a -> (junk m >>= fun () -> Monad.return(Some (f a)))
+      | None -> Monad.return None
+    in
+    from f
 
   let map_list f m =
     let page = ref [] in
@@ -260,7 +265,17 @@ struct
     from (fun _ -> junk_while not_p m >>= fun () -> peek m)
 
   let filter_map f m =
-    from (fun _ -> peek m >|= (function Some a -> f a | None -> None))
+    let rec next serial =
+      Monad.bind (get m)
+        begin function
+          | Some(a) -> begin match f a with
+              | Some(x) -> Monad.return(Some x)
+              | None -> next serial
+            end
+          | None -> Monad.return None
+        end
+    in
+    from next
 
   let flatten m =
     map_list (fun lst -> lst) m

testsuite/Makefile

@@ -23,6 +23,7 @@ SRCS+=			testPPX.ml
 .endif
 
 SRCS+=			testStream.ml
+SRCS+=			testSuccessReader.ml
 SRCS+=			main.ml
 
 OCAMLLFLAGS+=		-linkall

testsuite/testStream.ml

@@ -48,8 +48,51 @@ let () =
       (fun () -> SStream.fold ( + ) (enumerate 10) 0)
       ()
       (Success.Success 45);
+
     assert_success_int "fail"
       (fun () -> SStream.fold ( + ) (fail 10) 0)
       ()
       (Success.Error "Error");
+
+    assert_success_int "map"
+      (fun () ->
+         SStream.fold
+           ( + )
+           (SStream.map (fun x -> 2 * x) (enumerate 10))
+           0)
+      ()
+      (Success.Success 90);
+
+    assert_success_int "npeek"
+      (fun () ->
+         Success.map List.length
+           (SStream.npeek 15 (enumerate 10)))
+      ()
+      (Success.Success 10);
+
+
+    assert_success_int "concat"
+      (fun () ->
+         let pyramid n =
+           SStream.from
+             Success.(fun i -> if i >= 0 && i < n then return(Some(enumerate i)) else return None)
+         in
+         SStream.fold
+           ( + )
+           (SStream.concat (pyramid 5))
+           0)
+      ()
+      (Success.Success (3 + 2 + 1 + 2 + 1 + 1));
+
+
+    assert_success_int "filter_map"
+      (fun () ->
+         let stream =
+           SStream.filter_map
+             (fun n -> if n mod 2 = 0 then Some(n) else None)
+             (enumerate 10)
+         in
+         SStream.fold ( + ) stream 0)
+      ()
+      (Success.Success (2 + 4 + 6 + 8));
   ]

testsuite/testSuccessReader.ml

@@ -0,0 +1,92 @@
+(* TestSuccessReader -- Test natural transformation
+
+   Mixture (https://github.com/michipili/lemonade)
+   This file is part of Lemonade
+
+   Copyright © 2013–2016 Michael Grünewald
+
+   This file must be used under the terms of the CeCILL-B.
+   This source file is licensed as described in the file COPYING, which
+   you should have received as part of this distribution. The terms
+   are also available at
+   http://www.cecill.info/licences/Licence_CeCILL-B_V1-en.txt *)
+
+open Format
+open Broken
+
+module Error =
+struct
+  type t = string * string
+end
+
+module Success =
+  Lemonade_Success.Make(Error)
+
+module Environment =
+struct
+  type t = string
+end
+
+module Reader =
+  Lemonade_Reader.Make(Environment)
+
+module Basis =
+  Reader.T(Success)
+
+include Basis
+
+type 'a outcome = 'a Success.outcome =
+  | Success of 'a
+  | Error of Error.t
+
+let error err =
+  Basis.lift(Success.error err)
+
+
+(* Lift operations from the success monad *)
+
+let run env m =
+  Success.run(Basis.run env m)
+
+let recover m f =
+  let g x =
+    Success.return(f x)
+  in
+  let m' =
+    Reader.bind m
+      (fun s -> Reader.return(Success.recover (Success.map Basis.return s) g))
+  in
+  Basis.join m'
+
+(* Pretty printing *)
+
+let pp_print_outcome_list_string pp m =
+  let pp_print_list_string pp lst =
+    Lemonade_List.pp_print pp_print_string pp lst
+  in
+  let pp_print_outcome f pp =
+    function
+    | Success(x) -> fprintf pp "Success(%a)" f x
+    | Error(name, mesg) -> fprintf pp "Error(%S, %S)" name mesg
+  in
+  pp_print_outcome pp_print_list_string pp m
+
+let assert_outcome name env f expected =
+  assert_equal ~printer:pp_print_outcome_list_string
+    name (fun () -> run env f) () expected
+
+let () =
+  register_suite "success_reader"
+    "Test the Success Reader natural transformation"
+    [
+      assert_outcome "prefix"
+        "prefix"
+        (Basis.access begin fun prefix -> [ prefix ^ "-a"; prefix ^ "-b"] end)
+        (Success [ "prefix-a"; "prefix-b"]);
+
+      assert_outcome "join"
+        "join"
+        (Basis.join (Basis.access begin
+             fun prefix -> Reader.return(Success.return [ prefix ^ "-a" ]) end))
+        (Success ["join-a"]);
+    ]