linear_monad.dats

#include "share/atspre_staload.hats"

vtypedef llist(a:vt@ype) = List_vt(a)


extern fun{fa,a0:vt0p}{fb,b0:vt0p}
monad_bind: (!fa) -> fb
extern fun{a0:vt0p}{fb,b0:vt0p}
monad_bind$f: (!a0) -> fb

extern fun{fa,a0:vt0p}{fb,b0:vt0p}
monad_fmap: (!fa) -> fb
extern fun{a0:vt0p}{b0:vt0p}
monad_fmap$f: (!a0) -> b0


extern fun{fa,a0:vt0p}{fb,b0:vt0p}
monad_bind_free: fa -> fb
extern fun{a0:vt0p}{fb,b0:vt0p}
monad_bind_free$f: a0 -> fb

extern fun{fa,a0:vt0p}{fb,b0:vt0p}
monad_fmap_free: (fa) -> fb
extern fun{a0:vt0p}{b0:vt0p}
monad_fmap_free$f: a0 -> b0

extern fun{fa,a0:vt0p}
monad_return(x0: a0): fa

implement(a:vt@ype)
monad_return<llist(a),a>(x0) = list_vt_sing(x0)


implement(a,b:t@ype)
monad_bind<llist(a),a><llist(b),b>(fx) =
  list_vt_concat<b>(list_vt_map<a><llist(b)>(fx)) where
    implement
    list_vt_map$fopr<a><llist(b)>(x) =
      monad_bind$f<a><llist(b),b>(x)
  end

implement{fa,a0}{fb,b0}
monad_fmap(fx) =
(
  monad_bind<fa,a0><fb,b0>(fx) where
    implement
    monad_bind$f<a0><fb,b0>(x0) =
      (monad_return<fb,b0>(monad_fmap$f<a0><b0>(x0)))
  end
)

implement(a,b:t@ype)
monad_bind_free<llist(a),a><llist(b),b>(fx) =
  list_vt_concat<b>(list_vt_mapfree<a><llist(b)>(fx)) where
    implement
    list_vt_mapfree$fopr<a><llist(b)>(x) =
      monad_bind_free$f<a><llist(b),b>(x)
  end

implement{fa,a0}{fb,b0}
monad_fmap_free(fx) =
(
  monad_bind_free<fa,a0><fb,b0>(fx) where
    implement
    monad_bind_free$f<a0><fb,b0>(x0) =
      (monad_return<fb,b0>(monad_fmap_free$f<a0><b0>(x0)))
  end
)

local

implement fprint_list_vt$sep<>(out) = ()

in

fun test_free(): void =
{
  val xs = $list_vt{int}(70,114,101,101,100)

  val ys = monad_fmap_free<llist(int),int><llist(char),char>(xs) where
    implement
    monad_fmap_free$f<int><char>(x) = int2char0(x)
  end

  val () = println!(ys)

  val () = list_vt_free(ys)
}

fun test_preserve(): void =
{
  val xs = $list_vt{int}(80,114,101,115,101,114,118,101,100)

  val ys = monad_fmap<llist(int),int><llist(char),char>(xs) where
    implement
    monad_fmap$f<int><char>(x) = int2char0(x)
  end

  val () = println!(ys)

  // notice: xs was preserved so we need to free it...
  val () = list_vt_free(xs)
  val () = list_vt_free(ys)
}

end

implement main0() = (test_free(); test_preserve())