(M : MONAD_SEQUENCE) (F : FUNCTOR) :
  sig val mapM : ('a -> 'b M.m) -> 'a F.t -> ('b F.t) M.m
         end =
  struct
    let (index : 'a F.t -> ((int F.t) * ('a array))) =
      fun f_t_a ->
        let bld = Array.Build.create () in
        let i = ref (-1) in
        let f_t_int =
          F.fmap (fun x -> (Array.Build.add x bld; incr i; !i)) f_t_a
        in (f_t_int, (Array.Build.get bld))
      
    let (deindex : int F.t -> 'b array -> 'b F.t) =
      fun f_t_int arr -> F.fmap (fun i -> arr.(i)) f_t_int
      
    let ( >>= ) = M.bind_rev
      
    let mapM mapfunc f_t_a =
      let (f_t_int, arr_a) = index f_t_a in
      let arr_m_b = Array.map mapfunc arr_a
      in
        (M.sequence_array arr_m_b) >>=
          (fun arr_b -> let f_t_b = deindex f_t_int arr_b in M.return f_t_b)
      
  end