module type MonadError =
  sig
    type +'a m
    
    val return : 'a -> 'a m
      
    val bind : ('a -> 'b m) -> 'a m -> 'b m
      
    val bind_rev : 'a m -> ('a -> 'b m) -> 'b m
      
    val error : exn -> 'a m
      
    val catch : (unit -> 'a m) -> (exn -> 'a m) -> 'a m
      
  end
  
module Identity =
  struct
    type +'a m = 'a
    
    external return : 'a -> 'a m = "%identity"
      
    let bind f m = f m
      
    let bind_rev m f = f m
      
    let error = raise
      
    let catch func handler = try func () with | e -> handler e
      
  end
  
module LwtIO =
  struct
    type +'a m = 'a Lwt.t
    
    let return = Lwt.return
      
    let bind = Lwt.( =<< )
      
    let bind_rev = Lwt.( >>= )
      
    let error = Lwt.fail
      
    let catch = Lwt.catch
      
  end
  
(*
module TestIdentity = (Identity : MonadError);
module TestLwtIO = (LwtIO : MonadError);
*)
module W (M : MonadError) :
  sig
    type ('a, 'r) withres = { cons : 'a -> 'r M.m; fin : 'r -> unit M.m }
    
    val bindres : ('a, 'r) withres -> 'a -> ('r -> 'z M.m) -> 'z M.m
      
    val with_alt :
      ('a, 'r) withres ->
        ('b, 'r) withres -> (('a * 'b), ((exn option) * 'r)) withres
      
    val with_identity : ('r, 'r) withres
      
    val premap : ('a -> 'b) -> ('b, 'r) withres -> ('a, 'r) withres
      
    type dir_abstract
    
    val with_sys_chdir : (string, dir_abstract) withres
      
  end =
  struct
    type ('a, 'r) withres = { cons : 'a -> 'r M.m; fin : 'r -> unit M.m }
    
    let ( %> ) f g x = g (f x)
      
    let premap : ('a -> 'b) -> ('b, 'r) withres -> ('a, 'r) withres =
      fun ab wbr -> { cons = ab %> wbr.cons; fin = wbr.fin; }
      
    let with_identity = { cons = M.return; fin = (fun _r -> M.return ()); }
      
    let ( >>= ) = M.bind_rev
      
    let 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)))
      
    let 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 := wr2.fin; M.return ((Some e), r)))));
          fin = (fun (_opt_err, r) -> !fin r);
        }
      
    type dir_abstract = string
    
    let with_sys_chdir : (string, dir_abstract) withres =
      {
        cons =
          (fun new_dir ->
             M.catch
               (fun () ->
                  let old_dir = Sys.getcwd () in
                  let () = Sys.chdir new_dir in M.return old_dir)
               M.error);
        fin =
          (fun old_dir ->
             M.catch (fun () -> M.return (Sys.chdir old_dir)) M.error);
      }
      
  end
  
module WithI = W(Identity)
  
module WithLwtIO = W(LwtIO)
  
module WithRes = W(Res)