diff --git a/.travis.yml b/.travis.yml index 8aabab8..7f0ec94 100644 --- a/.travis.yml +++ b/.travis.yml @@ -5,6 +5,7 @@ addons: sources: - avsm packages: + - aspcud - ocaml - opam - ocaml-native-compilers diff --git a/Makefile b/Makefile index ad74e88..7a2902f 100644 --- a/Makefile +++ b/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= michipili@gmail.com .sinclude "Makefile.config" diff --git a/opam/opam b/opam/opam index ed5c4dd..a2257d5 100644 --- a/opam/opam +++ b/opam/opam @@ -1,7 +1,7 @@ opam-version: "1.2" maintainer: "michipili@gmail.com" 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" diff --git a/ppx/ppx_lemonade.ml b/ppx/ppx_lemonade.ml index 233e26a..0aa60f7 100644 --- a/ppx/ppx_lemonade.ml +++ b/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 diff --git a/src/lemonade_Reader.mli b/src/lemonade_Reader.mli index 3bb5e85..7620671 100644 --- a/src/lemonade_Reader.mli +++ b/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. *) diff --git a/src/lemonade_Stream.ml b/src/lemonade_Stream.ml index 0c432e4..a777043 100644 --- a/src/lemonade_Stream.ml +++ b/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 diff --git a/testsuite/Makefile b/testsuite/Makefile index 5d27900..9dac5fb 100644 --- a/testsuite/Makefile +++ b/testsuite/Makefile @@ -23,6 +23,7 @@ SRCS+= testPPX.ml .endif SRCS+= testStream.ml +SRCS+= testSuccessReader.ml SRCS+= main.ml OCAMLLFLAGS+= -linkall diff --git a/testsuite/testStream.ml b/testsuite/testStream.ml index 7d513b4..74f2d50 100644 --- a/testsuite/testStream.ml +++ b/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)); ] diff --git a/testsuite/testSuccessReader.ml b/testsuite/testSuccessReader.ml new file mode 100644 index 0000000..263fea1 --- /dev/null +++ b/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"]); + ]