Source

amall / src / mapM.ml

Full commit
open Amall_types;
open Am_Array;


module Make (M : MONAD_SEQUENCE) (F : FUNCTOR)
 :
  sig
    value mapM : ('a -> M.m 'b) -> F.t 'a -> M.m (F.t 'b);
  end
 =
  struct

    value (index : F.t 'a -> (F.t int * array 'a)) 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.val
           )
        )
        f_t_a
      in
      (f_t_int, Array.Build.get bld)
    ;

    value (deindex : F.t int -> array 'b -> F.t 'b) f_t_int arr =
      F.fmap (fun i -> arr.(i)) f_t_int
    ;


    value ( >>= ) = M.bind_rev
    ;

    value 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
;