Commits

Dmitry Grebeniuk  committed d6a11d0

+ WithM

  • Participants
  • Parent commits 12a87e7

Comments (0)

Files changed (5)

 (* OASIS_START *)
-(* DO NOT EDIT (digest: f7a66760511e809123c5ea6837cb8669) *)
+(* DO NOT EDIT (digest: f6151826df872ab59b38fdc515818341) *)
 This is the README file for the amall distribution.
 
 Amatei OCaml library.
 
 Amatei OCaml library with stdlib extensions, database interface, http 
-protocol implementation, with-combinators, module for files (Filew) and so
-on. Commits made by Dmitry Grebeniuk are sponsored by Amatei.
+protocol implementation, with-combinators (monadic too), module for files
+(Filew) and so on. Commits made by Dmitry Grebeniuk are sponsored by Amatei.
 
 See the files INSTALL.txt for building and installation instructions. See the
 file LICENSE for copying conditions. 
 BuildTools: ocamlbuild
 Description:
   Amatei OCaml library with stdlib extensions, database interface,
-  http  protocol implementation, with-combinators, module for
-  files (Filew) and so on.
+  http  protocol implementation, with-combinators (monadic too),
+  module for files (Filew) and so on.
   Commits made by Dmitry Grebeniuk are sponsored by Amatei.
 
 Flag dbi
     SortedArray,
     SortedArraySet,
     With_comb,
-    Filepath
+    Filepath,
+    WithM
   InternalModules:
     Am_Common,
     ExtStream,
 (* setup.ml generated for the first time by OASIS v0.2.1~alpha1 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: d5bf596a2c3ab9311efd7f3efb8a3ade) *)
+(* DO NOT EDIT (digest: 0cb3f02282bf5e4b8796dc4d7d8b3e4d) *)
 (*
    Regenerated by OASIS v0.2.1~alpha1
    Visit http://oasis.forge.ocamlcore.org for more information and
           synopsis = "Amatei OCaml library.";
           description =
             Some
-              "Amatei OCaml library with stdlib extensions, database interface,\nhttp  protocol implementation, with-combinators, module for\nfiles (Filew) and so on.\nCommits made by Dmitry Grebeniuk are sponsored by Amatei.";
+              "Amatei OCaml library with stdlib extensions, database interface,\nhttp  protocol implementation, with-combinators (monadic too),\nmodule for files (Filew) and so on.\nCommits made by Dmitry Grebeniuk are sponsored by Amatei.";
           categories = [];
           conf_type = (`Configure, "internal", Some "0.2");
           conf_custom =
                            "SortedArray";
                            "SortedArraySet";
                            "With_comb";
-                           "Filepath"
+                           "Filepath";
+                           "WithM"
                         ];
                       lib_internal_modules =
                         [

File src/amall.mllib

 # OASIS_START
-# DO NOT EDIT (digest: f634917a8ee70cf571d16ef1201e859b)
+# DO NOT EDIT (digest: 45fb21922d70d4870ebe61db38686ef7)
 Am_All
 Am_Ops
 Amall_types
 SortedArraySet
 With_comb
 Filepath
+WithM
 Am_Common
 ExtStream
 ExtString

File src/withM.ml

+module type MonadError
+ =
+  sig
+    type m +'a;
+    value return : 'a -> m 'a;
+    value bind : ('a -> m 'b) -> m 'a -> m 'b;
+    value bind_rev : m 'a -> ('a -> m 'b) -> m 'b;
+    value error : exn -> m 'a;
+    value catch : (unit -> m 'a) -> (exn -> m 'a) -> m 'a;
+  end
+;
+
+
+module Identity
+ =
+  struct
+    type m +'a = 'a;
+    external return : 'a -> m 'a = "%identity";
+    value bind f m = f m;
+    value bind_rev m f = f m;
+    value error = raise;
+    value catch func handler = try func () with [e -> handler e];
+  end
+;
+
+
+module LwtIO
+ =
+  struct
+    type m +'a = Lwt.t 'a;
+    value return = Lwt.return;
+    value bind = Lwt.( =<< );
+    value bind_rev = Lwt.( >>= );
+    value error = Lwt.fail;
+    value catch = Lwt.catch;
+  end
+;
+
+
+module TestIdentity = (Identity : MonadError);
+module TestLwtIO = (LwtIO : MonadError);
+
+
+module W (M : MonadError)
+ :
+  sig 
+
+    type withres 'a 'r =
+      { cons : 'a -> M.m 'r
+      ; fin : 'r -> M.m unit
+      }
+    ;
+
+    value bindres : withres 'a 'r -> 'a -> ('r -> M.m 'z) -> M.m 'z
+    ;
+
+    value with_alt :
+      withres 'a 'r ->
+      withres 'b 'r ->
+      withres ('a * 'b) (option exn * 'r)
+    ;
+
+    value with_identity : withres 'r 'r;
+
+  end
+ =
+  struct
+
+    type withres 'a 'r =
+      { cons : 'a -> M.m 'r
+      ; fin : 'r -> M.m unit
+      }
+    ;
+
+    value with_identity =
+      { cons = M.return
+      ; fin = fun _r -> M.return ()
+      }
+    ;
+
+    value ( >>= ) = M.bind_rev;
+
+    value bindres wr a f =
+      wr.cons a >>= fun r ->
+      M.catch
+        (fun () ->
+           f r >>= fun z ->
+           wr.fin r >>= fun () ->
+           M.return z
+        )
+        (fun e ->
+           wr.fin r >>= fun () ->
+           M.error e
+        )
+    ;
+
+    value with_alt wr1 wr2 =
+      let fin = ref wr1.fin in
+      { cons = fun (a, b) ->
+          M.catch
+            (fun () ->
+               wr1.cons a >>= fun r ->
+               M.return (None, r)
+            )
+            (fun e ->
+               wr2.cons b >>= fun r ->
+               ( fin.val := wr2.fin
+               ; M.return (Some e, r)
+               )
+            )
+      ; fin = fun (_opt_err, r) -> fin.val r
+      }
+    ;
+
+  end
+;