(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